Commit 8a11a385 authored by Michal Terepeta's avatar Michal Terepeta Committed by Ben Gamari

real: remove ebnf2ps

Summary:
The benchmark doesn't compile and even after fixing, it runs in about
0.006s. The compile time is super fast as well (tiny modules).  So it
seems like another candidate for removal.
Signed-off-by: Michal Terepeta's avatarMichal Terepeta <michal.terepeta@gmail.com>

Test Plan: run nofib

Reviewers: goldfire, bgamari

Reviewed By: bgamari

Differential Revision: https://phabricator.haskell.org/D3087
parent 5786292b
......@@ -7,7 +7,7 @@ SUBDIRS = anna bspt cacheprof compress compress2 fem fluid fulsom gamteb gg \
# Omitted:
# HMMS binary file endian-ness problems
OTHER_SUBDIRS = HMMS PolyGP ebnf2ps linear rx
OTHER_SUBDIRS = HMMS PolyGP linear rx
include $(TOP)/mk/target.mk
module AbstractSyntax (Production (..)) where
-- Copyright 1994 by Peter Thiemann
data Production
= ProdFile [Production]
| ProdProduction String [String] Production -- optional print name
| ProdTerm [Production] -- an alternative of terms
| ProdFactor [Production] -- a sequence of factors
| ProdNonterminal String
| ProdTerminal String
| ProdOption Production
| ProdRepeat Production
| ProdRepeatWithAtom Production Production
| ProdRepeat1 Production
| ProdPlus -- a helper
| ProdSlash Production -- another helper
deriving Eq
-- -*- Mode: Haskell -*-
-- Copyright 1994 by Peter Thiemann
-- Color.hs --- string converter for colors
-- Author : Peter Thiemann
-- Created On : Thu Dec 2 16:58:33 1993
-- Last Modified By: Peter Thiemann
-- Last Modified On: Fri Dec 3 14:13:34 1993
-- Update Count : 3
-- Status : Unknown, Use with caution!
--
-- $Locker: $
-- $Log: Color.hs,v $
-- Revision 1.3 1999/01/18 19:38:46 sof
-- Misc (backward compatible) changes to make srcs acceptable
-- to a Haskell 98 compiler.
--
-- Revision 1.2 1996/07/25 21:23:51 partain
-- Bulk of final changes for 2.01
--
-- Revision 1.1 1996/01/08 20:02:35 partain
-- Initial revision
--
-- Revision 1.1 1994/03/15 15:34:53 thiemann
-- Initial revision
--
--
module Color where
-- (Color (..), lookupColor, showsColor, prepareColors)
import Data.Char -- 1.3
import Data.List ((\\)) -- 1.3
type Color = (Int, Int, Int)
noColor :: Color
noColor = (-1, -1, -1)
{-
readColor :: String -> Color
readColor = readColor1 . map toLower
readColor1 :: String -> Color
readColor1 ('b':'l':'a':_) = 0
readColor1 ('b':'l':'u':_) = 1
readColor1 ('g':_) = 2
readColor1 ('c':_) = 3
readColor1 ('r':_) = 4
readColor1 ('m':_) = 5
readColor1 ('y':_) = 6
readColor1 ('w':_) = 7
readColor1 _ = -1
-}
lookupColor :: String -> [(String, (a, b, c))] -> (a, b, c)
lookupColor colorName colorTable =
head [(r,g,b) | (c,(r,g,b)) <- colorTable, c == map toLower colorName]
showsColor :: Color -> ShowS
showsColor (r,g,b) = showString " (" . shows r . showChar ',' .
shows g . showChar ',' .
shows b . showChar ')'
prepareColors rgbFile colors =
decodeColors (map (map toLower) colors) (fallBackRgb++parsedRgbFile) []
where parsedRgbFile = (map parseLine (lines rgbFile))
decodeColors [] parsedRgbFile decoded = decoded
decodeColors clrs [] decoded = [(name,(128,128,128)) | name <- clrs ]++decoded
decodeColors clrs ((r,g,b,name):parsedRgbFile) decoded
= decodeColors (clrs \\ found) parsedRgbFile (foundDecoded++decoded)
where found = [ c | c <- clrs, name == c ]
foundDecoded = [ (c,(r,g,b)) | c <- found ]
parseLine str = let (r,restr):_ = reads{-was:readDec-} (skipWhite str)
(g,restg):_ = reads{-was:readDec-} (skipWhite restr)
(b,restb):_ = reads{-was:readDec-} (skipWhite restg)
name = skipWhite restb
in (r,g,b,name)
where skipWhite = dropWhile isSpace
fallBackRgb :: [(Int,Int,Int,String)]
fallBackRgb = [
( 0, 0, 0,"black"),
( 0, 0,255,"blue"),
( 0,255, 0,"green"),
( 0,255,255,"cyan"),
(255, 0, 0,"red"),
(255, 0,255,"magenta"),
(255,255, 0,"yellow"),
(255,255,255,"white")]
showsPsColor (r,g,b) = showChar ' ' . shows r .
showChar ' ' . shows g .
showChar ' ' . shows b .
showString " scol"
showsFigColor (r,g,b) = showChar ' ' . shows (minPosition 0 (-1,32768*32768)
[ (x-r)*(x-r) + (y-g)*(y-g) + (z-b)*(z-b) | (x,y,z,_) <- fallBackRgb ])
--
-- find position of minimal element in list
--
minPosition i (pos,min) [] = pos
minPosition i (pos,min) (x:rest) | x < min = minPosition (i+1) (i,x) rest
| otherwise = minPosition (i+1) (pos,min) rest
module CommandLine (parse_cmds) where
-- Copyright 1994 by Peter Thiemann
import System.Environment
import System.IO
defaultArgs :: Args
defaultArgs = MkArgs "Times-Roman" 10 "black" "Times-Roman" 10 "black" "black" "black" 500 500 30 100 200 "rgb.txt" False False True False False False
usage :: IO ()
usage = hPutStr stderr "Usage: prog [-ntFont String] [-ntScale Int] [-ntColor String] [-tFont String] [-tScale Int] [-tColor String] [-lineColor String] [-fatLineColor String] [-borderDistX Int] [-borderDistY Int] [-lineWidth Int] [-fatLineWidth Int] [-arrowSize Int] [-rgbFileName String] [-happy] [(+|-)simplify] [(+|-)ps] [(+|-)fig] [-help] [-verbose]"
data Args = MkArgs String Int String String Int String String String Int Int Int Int Int String Bool Bool Bool Bool Bool Bool deriving ()
type ProgType = String -> Int -> String -> String -> Int -> String -> String -> String -> Int -> Int -> Int -> Int -> Int -> String -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> [String] -> IO ()
parse_args :: ProgType -> Args -> [String] -> IO ()
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) ("-ntFont":rest)
= readstring (\str -> parse_args prog (MkArgs str x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20)) rest
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) ("-ntScale":rest)
= readval reads (\val -> parse_args prog (MkArgs x1 val x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20)) rest
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) ("-ntColor":rest)
= readstring (\str -> parse_args prog (MkArgs x1 x2 str x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20)) rest
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) ("-tFont":rest)
= readstring (\str -> parse_args prog (MkArgs x1 x2 x3 str x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20)) rest
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) ("-tScale":rest)
= readval reads (\val -> parse_args prog (MkArgs x1 x2 x3 x4 val x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20)) rest
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) ("-tColor":rest)
= readstring (\str -> parse_args prog (MkArgs x1 x2 x3 x4 x5 str x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20)) rest
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) ("-lineColor":rest)
= readstring (\str -> parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 str x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20)) rest
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) ("-fatLineColor":rest)
= readstring (\str -> parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 str x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20)) rest
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) ("-borderDistX":rest)
= readval reads (\val -> parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 val x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20)) rest
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) ("-borderDistY":rest)
= readval reads (\val -> parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 val x11 x12 x13 x14 x15 x16 x17 x18 x19 x20)) rest
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) ("-lineWidth":rest)
= readval reads (\val -> parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 val x12 x13 x14 x15 x16 x17 x18 x19 x20)) rest
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) ("-fatLineWidth":rest)
= readval reads (\val -> parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 val x13 x14 x15 x16 x17 x18 x19 x20)) rest
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) ("-arrowSize":rest)
= readval reads (\val -> parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 val x14 x15 x16 x17 x18 x19 x20)) rest
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) ("-rgbFileName":rest)
= readstring (\str -> parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 str x15 x16 x17 x18 x19 x20)) rest
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) ("-happy":rest)
= readbool (parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 True x16 x17 x18 x19 x20)) rest
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) ("-simplify":rest)
= readbool (parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 False x17 x18 x19 x20)) rest
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) ("+simplify":rest)
= readbool (parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 True x17 x18 x19 x20)) rest
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) ("-ps":rest)
= readbool (parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 False x18 x19 x20)) rest
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) ("+ps":rest)
= readbool (parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 True x18 x19 x20)) rest
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) ("-fig":rest)
= readbool (parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 False x19 x20)) rest
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) ("+fig":rest)
= readbool (parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 True x19 x20)) rest
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) ("-help":rest)
= readbool (parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 True x20)) rest
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) ("-verbose":rest)
= readbool (parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 True)) rest
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) (('-': _) :rest)
= usage
parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20) rest = prog x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 rest
parse_cmds :: ProgType -> IO ()
parse_cmds prog = getArgs >>= parse_args prog defaultArgs
readbool :: ([String] -> IO ()) -> [String] -> IO ()
readbool f = f
readstring :: (String -> [String] -> IO ()) -> [String] -> IO ()
readstring f (str: rest) = f str rest
readstring f [] = usage
readval :: (Read a) => ReadS a -> (a -> [String] -> IO ()) -> [String] -> IO ()
readval readsfn f (str: rest)
= case readsfn str of
((val, ""):_) -> f val rest
_ -> usage
-ntFont String "Times-Roman"
-ntScale Int 10
-ntColor String "black"
-tFont String "Times-Roman"
-tScale Int 10
-tColor String "black"
-lineColor String "black"
-fatLineColor String "black"
-borderDistX Int 500
-borderDistY Int 500
-lineWidth Int 30
-fatLineWidth Int 100
-arrowSize Int 200
-rgbFileName String "rgb.txt"
-happy Bool False
+simplify Bool False
+ps Bool True
+fig Bool False
-help Bool False
-verbose Bool False
-- -*- Mode: Haskell -*-
-- Copyright 1994 by Peter Thiemann
-- EbnfGrammar.hs --- a simple combinator parser for a grammar in EBNF
-- Author : Peter Thiemann
-- Created On : Tue Aug 3 10:30:03 1993
-- Last Modified By: Peter Thiemann
-- Last Modified On: Mon Dec 27 17:41:17 1993
-- Update Count : 13
-- Status : Unknown, Use with caution!
--
--------------------------------------------------
-- $Log: EbnfGrammar.hs,v $
-- Revision 1.1 1996/01/08 20:02:34 partain
-- Initial revision
--
-- Revision 1.3 1994/03/15 15:34:53 thiemann
-- added full color support, XColorDB based
--
--Revision 1.2 1993/08/31 12:31:32 thiemann
--reflect changes in type FONT
--
--Revision 1.1 1993/08/17 12:34:29 thiemann
--Initial revision
--
-- $Locker: $
--------------------------------------------------
module EbnfGrammar (parseAll) where
import Parsers
import Lexer
import AbstractSyntax
parseAll s = [ prod | (prod, []) <- parseFile (lexer (uncomment s)) ]
-- This is the grammar for EBNF
-- File = {Production}.
-- Production = Nonterminal [ String ] "=" Term "." .
-- Term = Factor / "|" . # alternative
-- Factor = ExtAtom + . # sequence
-- ExtAtom = Atom
-- | Atom "/" Atom # repetion through Atom
-- | Atom "+". # at least one repetion
-- Atom = Nonterminal
-- | String # terminal string
-- | "(" Term ")"
-- | "[" Term "]" # an optional Term
-- | "{" Term "}" # zero or more repetions
-- .
-- String = "\"" { character } "\"" .
-- Nonterminal = letter { letter | digit | "_" } .
-- character = "\\" charesc.
parseFile = rpt parseProduction -- no longer `using` ProdFile
parseProduction = (satisfy isIdent `thn`
opt (satisfy isString) `thn`
expectSymbol "=" `xthn`
parseTerm `thnx`
expectSymbol ".") `using`
\(nt, (ntNames, term)) -> ProdProduction (getIdent nt) (map getString ntNames) term
parseTerm = (parseFactor `thn`
rpt (expectSymbol "|" `xthn` parseFactor))
`using2` (:) `using` ProdTerm
parseFactor = (parseExtendedAtom `thn` rpt parseExtendedAtom)
`using2` (:) `using` ProdFactor
parseExtendedAtom = parseAtom `thn`
opt ((expectSymbol "+" `using` \ _ -> ProdPlus)
`alt`
(expectSymbol "/" `xthn` parseAtom `using` ProdSlash))
`using2` helper
where
helper term [] = term
helper term [ProdPlus] = ProdRepeat1 term
helper term [ProdSlash atom] = ProdRepeatWithAtom term atom
parseAtom = (expectSymbol "(" `xthn`
parseTerm `thnx`
expectSymbol ")")
`alt`
((expectSymbol "[" `xthn` parseTerm `thnx` expectSymbol "]")
`using` ProdOption)
`alt`
((expectSymbol "{" `xthn` parseTerm `thnx` expectSymbol "}")
`using` ProdRepeat)
`alt`
(satisfy isIdent `using` (ProdNonterminal . getIdent))
`alt`
(satisfy isString `using` (ProdTerminal . getString))
expectSymbol c = satisfy test
where test (Symbol x) = c == x
test _ = False
This diff is collapsed.
--------------------------------------------------------------------------------
-- Copyright 1994 by Peter Thiemann
-- $Log: FigOutput.hs,v $
-- Revision 1.1 1996/01/08 20:02:34 partain
-- Initial revision
--
-- Revision 1.2 1994/03/15 15:34:53 thiemann
-- added full color support, XColorDB based
--
-- Revision 1.1 1993/08/31 12:31:32 thiemann
-- Initial revision
--
-- $Locker: $
--------------------------------------------------------------------------------
module FigOutput (figShowsWrapper) where
import Fonts (FONT, fontName, fontScale)
import Color
import Info
--------------------------------------------------------------------------------
figShowsWrapper :: WrapperType
figShowsWrapper title
(borderDistX, borderDistY, lineWidth, fatLineWidth, arrowSize, ntFont, tFont, _)
container@(rx, ry, width, height, inOutY, gobj) =
showString "#FIG 2.1\n" .
showString "2 80\n" .
{- showString "1 80\n" . (origin in lower left) is ignored -}
figShowsContainer rx height container
where
figShowsContainer ax ay (rx, ry, width, height, inOutY, gobj) =
case gobj of
AString color font theString ->
showString "4 0" . -- object type, sub_type (left just)
showsTrueNum (figFont (fontName font)) . -- font (enumeration type)
showsTrueNum (fontScale font) . -- font_size (points)
showString " 0" . -- pen
showsFigColor color . -- color
showString " 0 0.00000 4" . -- depth, angle, font_flags
showsFigNum height . -- height
showsFigNum width . -- length
showsFigNum ax' . -- x
showsFigNum ay' . -- y
showString (' ':theString++"\1\n") -- string
ABox color rounded content ->
figShowsContainer ax' ay' content .
showString "2" .
showString (if rounded then " 4" else " 2") .
showString " 0 " . -- object, subobject (box), line style
showsFigNum fatLineWidth . -- thickness (pixels)
showsFigColor color . -- color
showString " 0 0 0" . -- depth, pen, area_fill
showString " 0.000" . -- style_val
(if rounded then showsFigNum (min width height `div` 2)
else showString " 0") .
showString " 0 0\n" . -- forward_arrow, backward_arrow
showsFigPoint ax' ay' .
showsFigPoint (ax'+width) ay' .
showsFigPoint (ax'+width) (ay'-height) .
showsFigPoint ax' (ay'-height) .
showsFigPoint ax' ay' .
showsFigLastPoint
Arrow color size ->
showString "2 1 0" . -- a polyline
showsFigNum lineWidth .
showsFigColor color .
showString " 0 0 0 0.000 -1 1 0\n" .
showString " 0 0" . -- arrow_type, arrow_style
showsFigNum lineWidth . showString ".000" . -- arrow_thickness
showsFigNum (abs size * 2) . showString ".000" . -- arrow_width
showsFigNum (abs size * 2) .showString ".000\n" . -- arrow_height
showString " " .
showsFigPoint (ax'-size) ay' .
showsFigPoint ax' ay' .
showsFigLastPoint
Aline color ->
showString "2 1 0" .
showsFigNum lineWidth .
showsFigColor color .
showString " 0 0 0 0.000 -1 0 0\n" .
showString " " .
showsFigPoint ax' ay' .
showsFigPoint (ax'+width) (ay'-height) .
showsFigLastPoint
ATurn color dir ->
showString "3 0 0" . -- a spline object
showsFigNum lineWidth .
showsFigColor color .
showString " 0 -1 0 0.0 0 0\n" .
showsIt dir .
showsFigLastPoint
where showsIt SE = showsFigPoint ax' ay' .
showsFigPoint ax' (ay'-height) .
showsFigPoint (ax'+width) (ay'-height)
showsIt WN = showsFigPoint ax' ay' .
showsFigPoint (ax'+width) ay' .
showsFigPoint (ax'+width) (ay'-height)
showsIt SW = showsFigPoint (ax'+width) ay' .
showsFigPoint (ax'+width) (ay'-height) .
showsFigPoint ax' (ay'-height)
showsIt NE = showsFigPoint ax' (ay'-height) .
showsFigPoint ax' ay' .
showsFigPoint (ax'+width) ay'
AComposite contents ->
showString "6" .
showsFigPoint (ax'+width) (ay'-height) .
showsFigPoint ax' ay' .
showChar '\n' .
foldr (.) (showString "-6\n") (map (figShowsContainer ax' ay') contents)
where ax' = ax + rx
ay' = ay - ry
figFont name = lookup figFontList 0
where
lookup [] _ = -1
lookup (font: fonts) n | font == name = n
| otherwise = lookup fonts (n+1)
figFontList = [ -- stolen from u_fonts.c
"Times-Roman",
"Times-Italic",
"Times-Bold",
"Times-BoldItalic",
"AvantGarde-Book",
"AvantGarde-BookOblique",
"AvantGarde-Demi",
"AvantGarde-DemiOblique",
"Bookman-Light",
"Bookman-LightItalic",
"Bookman-Demi",
"Bookman-DemiItalic",
"Courier",
"Courier-Oblique",
"Courier-Bold",
"Courier-BoldOblique",
"Helvetica",
"Helvetica-Oblique",
"Helvetica-Bold",
"Helvetica-BoldOblique",
"Helvetica-Narrow",
"Helvetica-Narrow-Oblique",
"Helvetica-Narrow-Bold",
"Helvetica-Narrow-BoldOblique",
"NewCenturySchlbk-Roman",
"NewCenturySchlbk-Italic",
"NewCenturySchlbk-Bold",
"NewCenturySchlbk-BoldItalic",
"Palatino-Roman",
"Palatino-Italic",
"Palatino-Bold",
"Palatino-BoldItalic",
"Symbol",
"ZapfChancery-MediumItalic",
"ZapfDingbats"]
showsTrueNum :: Int -> ShowS
showsTrueNum x = showChar ' ' . shows x
showsFigNum :: Int -> ShowS
showsFigNum x = showChar ' ' . shows ((x*9 + 999) `div` 1000) -- sorry about that
showsFigPoint :: Int -> Int -> ShowS
showsFigPoint x y = showsFigNum x . showsFigNum y
showsFigLastPoint :: ShowS
showsFigLastPoint = showString " 9999 9999\n"
-- showsFigColor :: Int -> ShowS
-- showsFigColor c = showChar ' ' . showsColor c
--------------------------------------------------------------------------------
-- Copyright 1994 by Peter Thiemann
-- $Log: Fonts.hs,v $
-- Revision 1.7 2000/01/24 17:14:26 simonmar
-- Undo fromInt changes: already converted to fromIntegral.
--
-- Revision 1.6 1999/12/08 09:56:37 simonmar
-- -syslib updates for new libraries.
--
-- Revision 1.5 1999/11/26 10:29:54 simonpj
-- fromInt wibble
--
-- Revision 1.4 1999/09/14 10:18:24 simonmar
-- Replace all instances of fromInt in nofib with fromIntegral.
--
-- We generate the same code in most cases :-)
--
-- Revision 1.3 1997/03/14 08:08:05 simonpj
-- Major update to more-or-less 2.02
--
-- Revision 1.2 1996/07/25 21:23:54 partain
-- Bulk of final changes for 2.01
--
-- Revision 1.1 1996/01/08 20:02:33 partain
-- Initial revision
--
-- Revision 1.1 1993/08/31 12:31:32 thiemann
-- Initial revision
--
-- Revision 1.1 1993/08/31 12:31:32 thiemann
-- Initial revision
--
-- $Locker: $
--------------------------------------------------------------------------------
module Fonts (FONT, makeFont, fontDescender, stringWidth, stringHeight, fontName, fontScale, noFont)
where
import Data.Char
-- not in 1.3
readDec :: (Integral a) => ReadS a
readDec = readInt 10 isDigit (\d -> ord d - ord_0)
readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
readInt radix isDig digToInt s =
[(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
| (ds,r) <- nonnull isDig s ]
ord_0 :: Num a => a
ord_0 = fromIntegral (ord '0')
nonnull :: (Char -> Bool) -> ReadS String
nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
readSigned :: (Real a) => ReadS a -> ReadS a
readSigned readPos = readParen False read'
where read' r = read'' r ++
[(-x,t) | ("-",s) <- lex r,
(x,t) <- read'' s]
read'' r = [(n,s) | (str,s) <- lex r,
(n,"") <- readPos str]
data FONT = FONT String Int Int (String -> Int)
instance Eq FONT where
FONT s1 m1 n1 f1 == FONT s2 m2 n2 f2 = s1 == s2 && m1 == m2 && n1 == n2
noFont = FONT "" 0 0 (const 0)
data Afm = Descender Int
| CharMetric Int Int String Int Int Int Int
-- CharMetric charNo charWX charName llx lly urx ury
-- deriving Text
fontName :: FONT -> String
fontName (FONT name _ _ _) = name
fontScale :: FONT -> Int
fontScale (FONT _ scale _ _) = scale
fontDescender :: FONT -> Int
fontDescender (FONT _ _ theDescender _) = theDescender
stringWidth :: FONT -> String -> Int
stringWidth (FONT _ _ _ theStringWidth) = theStringWidth
stringHeight :: FONT -> String -> Int
stringHeight (FONT _ scale _ _) _ = scale * 100
makeFont :: String -> Int -> String -> FONT
makeFont fontName fontScale fontAfm =
FONT fontName fontScale theDescender
((`div` 10). (* fontScale). getStringWidth parsedAfm)
where
parsedAfm = parseAfmFile (lines fontAfm)
theDescender = getDescender parsedAfm
getStringWidth :: [Afm] -> String -> Int
getStringWidth afms str = sum (map (getCharWidth afms . fromEnum) str)
getCharWidth :: [Afm] -> Int -> Int
getCharWidth (CharMetric charNo charWX charName llx lly urx ury: afms) chNo
| charNo == chNo = charWX
| otherwise = getCharWidth afms chNo
getCharWidth (_:afms) chNo = getCharWidth afms chNo
getCharWidth [] chNo = 0
getDescender :: [Afm] -> Int
getDescender (Descender d: _) = d
getDescender (_:rest) = getDescender rest
getDescender [] = 0
--------------------------------------------------------------------------------
parseAfmFile :: [String] -> [Afm]
parseAfmFile [] = []
parseAfmFile (('D':'e':'s':'c':'e':'n':'d':'e':'r':line):lines) =
Descender descender: parseAfmFile lines
where (descender,_):_ = readSigned readDec (skipWhite line)
parseAfmFile (('E':'n':'d':'C':'h':'a':'r':'M':'e':'t':'r':'i':'c':'s':_):_) = []
parseAfmFile (('C':' ':line):lines) = CharMetric charNo charWX charName llx lly urx ury:
parseAfmFile lines
where (charNo, rest1):_ = readSigned readDec (skipWhite line)
'W':'X':rest2 = skipWhiteOrSemi rest1
(charWX, rest3):_ = readDec (skipWhite rest2)
'N':rest4 = skipWhiteOrSemi rest3
(charName, rest5) = span isAlpha (skipWhite rest4)
'B':rest6 = skipWhiteOrSemi rest5
(llx, rest7):_ = readSigned readDec (skipWhite rest6)
(lly, rest8):_ = readSigned readDec (skipWhite rest7)
(urx, rest9):_ = readSigned readDec (skipWhite rest8)
(ury, _):_ = readSigned readDec (skipWhite rest9)
parseAfmFile (_:lines) = parseAfmFile lines
skipWhite = dropWhile isSpace
skipWhiteOrSemi = dropWhile isSkipChar
isSkipChar c = isSpace c || c == ';'
-- -*- Mode: Haskell -*-
-- Copyright 1994 by Peter Thiemann
-- GrammarTransform.hs --- some transformations on parse trees
-- Author : Peter Thiemann
-- Created On : Thu Oct 21 16:44:17 1993
-- Last Modified By: Peter Thiemann
-- Last Modified On: Mon Dec 27 17:41:16 1993
-- Update Count : 14
-- Status : Unknown, Use with caution!
--
-- $Locker: $
-- $Log: GrammarTransform.hs,v $
-- Revision 1.2 1997/03/14 08:08:06 simonpj
-- Major update to more-or-less 2.02
--
-- Revision 1.1 1996/01/08 20:02:35 partain
-- Initial revision
--
-- Revision 1.1 1994/03/15 15:34:53 thiemann
-- Initial revision
--
--
module GrammarTransform (simplify) where