diff --git a/Graphics/PS.hs b/Graphics/PS.hs new file mode 100644 --- /dev/null +++ b/Graphics/PS.hs @@ -0,0 +1,27 @@ +module Graphics.PS (module Graphics.PS.Pt, + module Graphics.PS.Bezier, + module Graphics.PS.Path, + module Graphics.PS.Glyph, + module Graphics.PS.Font, + module Graphics.PS.Image, + module Graphics.PS.Statistics, + module Graphics.PS.Transform, + module Graphics.PS.GS, + module Graphics.PS.Paper, + module Graphics.PS.Query, + module Graphics.PS.PS, + module Graphics.PS.Unit) where + +import Graphics.PS.Pt +import Graphics.PS.Bezier +import Graphics.PS.Path +import Graphics.PS.Glyph +import Graphics.PS.Font +import Graphics.PS.Image +import Graphics.PS.Transform +import Graphics.PS.GS +import Graphics.PS.Paper +import Graphics.PS.Query +import Graphics.PS.PS +import Graphics.PS.Unit +import Graphics.PS.Statistics diff --git a/Graphics/PS/Bezier.hs b/Graphics/PS/Bezier.hs new file mode 100644 --- /dev/null +++ b/Graphics/PS/Bezier.hs @@ -0,0 +1,22 @@ +module Graphics.PS.Bezier (bezier4) where + +import Graphics.PS.Pt + +{-- +bezier3 :: Pt -> Pt -> Pt -> Double -> Pt +bezier3 (Pt x1 y1) (Pt x2 y2) (Pt x3 y3) mu = (Pt x y) + where a = mu * mu + b = 1 - mu + c = b * b + x = x1 * c + 2 * x2 * b * mu + x3 * a + y = y1 * c + 2 * y2 * b * mu + y3 * a +--} + +bezier4 :: Pt -> Pt -> Pt -> Pt -> Double -> Pt +bezier4 (Pt x1 y1) (Pt x2 y2) (Pt x3 y3) (Pt x4 y4) mu = + let a = 1 - mu + b = a*a*a + c = mu*mu*mu + x = b*x1 + 3*mu*a*a*x2 + 3*mu*mu*a*x3 + c*x4 + y = b*y1 + 3*mu*a*a*y2 + 3*mu*mu*a*y3 + c*y4 + in Pt x y diff --git a/Graphics/PS/Font.hs b/Graphics/PS/Font.hs new file mode 100644 --- /dev/null +++ b/Graphics/PS/Font.hs @@ -0,0 +1,4 @@ +module Graphics.PS.Font (Font(..)) where + +data Font = Font String Double + deriving (Eq, Show) diff --git a/Graphics/PS/GS.hs b/Graphics/PS/GS.hs new file mode 100644 --- /dev/null +++ b/Graphics/PS/GS.hs @@ -0,0 +1,31 @@ +module Graphics.PS.GS ( GS(..) + , LineCap(..) + , LineJoin(..) + , Color(..) + , greyGS ) where + +data LineCap = ButtCap + | RoundCap + | ProjectingSquareCap + deriving (Eq, Show, Enum) + +type LineWidth = Double + +data LineJoin = MiterJoin + | RoundJoin + | BevelJoin + deriving (Eq, Show, Enum) + +data Color = RGB Double Double Double + deriving (Eq, Show) + +data GS = GS Color LineWidth LineCap LineJoin ([Int], Int) Double + deriving (Eq, Show) + +greyGS :: Double -> GS +greyGS g = GS (RGB g g g) 1.0 ButtCap MiterJoin ([], 0) 10.0 + +{-- +blackGS :: GS +blackGS = greyGS 0 +--} diff --git a/Graphics/PS/Glyph.hs b/Graphics/PS/Glyph.hs new file mode 100644 --- /dev/null +++ b/Graphics/PS/Glyph.hs @@ -0,0 +1,3 @@ +module Graphics.PS.Glyph (Glyph) where + +type Glyph = Char diff --git a/Graphics/PS/Image.hs b/Graphics/PS/Image.hs new file mode 100644 --- /dev/null +++ b/Graphics/PS/Image.hs @@ -0,0 +1,16 @@ +module Graphics.PS.Image (Image(..), over) where + +import qualified Graphics.PS.Matrix as M +import qualified Graphics.PS.Path as P +import qualified Graphics.PS.GS as G + +data Image = Stroke G.GS P.Path + | Fill G.GS P.Path + | ITransform M.Matrix Image + | Over Image Image + | Empty + deriving (Eq, Show) + +-- | Layer one image over another. +over :: Image -> Image -> Image +over = Over diff --git a/Graphics/PS/Matrix.hs b/Graphics/PS/Matrix.hs new file mode 100644 --- /dev/null +++ b/Graphics/PS/Matrix.hs @@ -0,0 +1,88 @@ +module Graphics.PS.Matrix ( Matrix(Matrix) + , identity + , translation, scaling, rotation ) where + +type R = Double + +data Matrix = Matrix R R R R R R + deriving (Eq, Show) + +type M = Matrix + +data MIx = I0 + | I1 + | I2 + deriving (Eq, Show, Enum) + +row :: M -> MIx -> (R, R, R) +row (Matrix a b _ _ _ _) I0 = (a, b, 0) +row (Matrix _ _ c d _ _) I1 = (c, d, 0) +row (Matrix _ _ _ _ e f) I2 = (e, f, 1) + +col :: M -> MIx -> (R, R, R) +col (Matrix a _ c _ e _) I0 = (a, c, e) +col (Matrix _ b _ d _ f) I1 = (b, d, f) +col (Matrix _ _ _ _ _ _) I2 = (0, 0, 1) + +multiply :: M -> M -> M +multiply a b = + let f i j = let (r1, r2, r3) = row a i + (c1, c2, c3) = col b j + in r1 * c1 + r2 * c2 + r3 * c3 + m = Matrix + in m (f I0 I0) (f I0 I1) (f I1 I0) (f I1 I1) (f I2 I0) (f I2 I1) + +pointwise :: (R -> R) -> M -> M +pointwise g (Matrix a b c d e f) = + Matrix (g a) (g b) (g c) (g d) (g e) (g f) + +pointwise2 :: (R -> R -> R) -> M -> M -> M +pointwise2 g (Matrix a b c d e f) (Matrix a' b' c' d' e' f') = + Matrix (g a a') (g b b') (g c c') (g d d') (g e e') (g f f') + +instance Num Matrix where + (*) = multiply + (+) = pointwise2 (+) + (-) = pointwise2 (-) + abs = pointwise abs + signum = pointwise signum + fromInteger n = let n' = fromInteger n + in Matrix n' 0 0 n' 0 0 + +translation :: R -> R -> M +translation = Matrix 1 0 0 1 + +scaling :: R -> R -> M +scaling x y = Matrix x 0 0 y 0 0 + +rotation :: R -> M +rotation a = + let c = cos a + s = sin a + t = negate s + in Matrix c s t c 0 0 + +identity :: M +identity = Matrix 1 0 0 1 0 0 + +{-- +translate :: R -> R -> M -> M +translate x y m = m * (translation x y) + +scale :: R -> R -> M -> M +scale x y m = m * (scaling x y) + +rotate :: R -> M -> M +rotate r m = m * (rotation r) + +scalarMultiply :: R -> M -> M +scalarMultiply scalar = pointwise (* scalar) + +adjoint :: M -> M +adjoint (Matrix a b c d x y) = M d (-b) (-c) a (c * y - d * x) (b * x - a * y) + +invert :: M -> M +invert m = scalarMultiply (recip d) (adjoint m) + where (Matrix xx yx xy yy _ _) = m + d = xx*yy - yx*xy +--} diff --git a/Graphics/PS/PS.hs b/Graphics/PS/PS.hs new file mode 100644 --- /dev/null +++ b/Graphics/PS/PS.hs @@ -0,0 +1,258 @@ +module Graphics.PS.PS (ps) where + +import Graphics.PS.Pt +import qualified Graphics.PS.Matrix as M +import Graphics.PS.Path +import Graphics.PS.Font +import Graphics.PS.Unit +import Graphics.PS.GS +import qualified Graphics.PS.Paper as P +import qualified Graphics.PS.Image as I +import Data.List +import System.IO + +data PS = Name String + | LName String + | Op String + | Comment String + | Int Int + | Double Double + | String String + | Matrix M.Matrix + | Array [PS] + | Proc [PS] + | Dict [(PS,PS)] + | Seq [PS] + +dsc :: String -> [String] -> PS +dsc k [] = Comment ('%' : k) +dsc k v = Comment (concat ("%" : k : ": " : intersperse " " v)) + +header :: PS +header = Comment "!PS-Adobe-3.0" + +title :: String -> PS +title t = dsc "Title" [t] + +creator :: String -> PS +creator t = dsc "Creator" [t] + +languageLevel :: Int -> PS +languageLevel n = dsc "LanguageLevel" [show n] + +pages :: Int -> PS +pages n = dsc "Pages" [show n] + +endComments :: PS +endComments = dsc "EndComments" [] + +page :: (Show a) => String -> a -> PS +page t n = dsc "Page" [t, show n] + +trailer :: PS +trailer = dsc "Trailer" [] + +eof :: PS +eof = dsc "EOF" [] + +documentMedia :: String -> Int -> Int -> PS +documentMedia tag w h = dsc "DocumentMedia" [tag, show w, show h, "0", "()", "()"] + +alias :: String -> String -> PS +alias o a = Seq [LName a, Proc [Name o], Op "def"] + +pdfCompat :: [(String, String)] +pdfCompat = [("gsave", "q"), + ("grestore", "Q"), + ("stroke", "S"), + ("fill", "f"), + ("setrgbcolor", "RG"), + ("setlinewidth", "w"), + ("setlinecap", "J"), + ("setlinejoin", "j"), + ("setdash", "d"), + ("setmiterlimit", "M"), + ("moveto", "m"), + ("lineto", "l"), + ("curveto", "c"), + ("closepath", "h"), + ("concat", "cm"), + ("show", "Tj"), + ("selectfont", "Tf"), + ("clip", "W")] + +prolog :: PS +prolog = + let f (a,b) = alias a b + in Seq (map f pdfCompat) + +stroke :: PS +stroke = Op "S" + +fill :: PS +fill = Op "f" + +false :: PS +false = Name "false" + +save :: PS +save = Seq [Op "matrix", Op "currentmatrix"] + +restore :: PS +restore = Op "setmatrix" + +showPage :: PS +showPage = Op "showpage" + +rgb :: Color -> PS +rgb (RGB r g b) = Seq [Double r, Double g, Double b, Op "RG"] + +lineWidth :: Double -> PS +lineWidth w = Seq [Double w, Op "w"] + +lineCap :: (Enum a) => a -> PS +lineCap c = Seq [Int (fromEnum c), Op "j"] + +lineJoin :: (Enum a) => a -> PS +lineJoin j = Seq [Int (fromEnum j), Op "J"] + +dash :: [Int] -> Int -> PS +dash d o = Seq [Array (map Int d), Int o, Op "d"] + +miterLimit :: Double -> PS +miterLimit m = Seq [Double m, Op "M"] + +moveTo :: Pt -> PS +moveTo (Pt x y) = Seq [Double x, Double y, Op "m"] + +lineTo :: Pt -> PS +lineTo (Pt x y) = Seq [Double x, Double y, Op "l"] + +transform :: M.Matrix -> PS +transform m = Seq [Matrix m, Op "cm"] + +curveTo :: Pt -> Pt -> Pt -> PS +curveTo a b c = Seq (map Double (ptXYs [a,b,c]) ++ [Op "c"]) + +selectFont :: Font -> PS +selectFont (Font f n) = Seq [LName f, Double n, Op "Tf"] + +charPath :: String -> PS +charPath g = Seq [String g, false, Op "charpath"] + +gs :: GS -> PS +gs (GS c w k j (d, o) m) = Seq [ rgb c + , lineWidth w + , lineCap k + , lineJoin j + , dash d o + , miterLimit m ] + +path :: Path -> PS +path (MoveTo p) = moveTo p +path (LineTo p) = lineTo p +path (Text f g) = Seq [selectFont f, charPath g] +path (CurveTo c1 c2 p) = curveTo c1 c2 p +path (PTransform m p) = Seq [ save + , transform m + , path p + , restore ] +path (Join a b) = Seq [path a, path b] + +image :: I.Image -> PS +image I.Empty = Comment "Empty" +image (I.Stroke g p) = Seq [path p, gs g, stroke] +image (I.Fill g p) = Seq [path p, gs g, fill] +image (I.ITransform m i) = Seq [ save + , transform m + , image i + , restore ] +image (I.Over a b) = Seq [image b, image a] + +mlist :: M.Matrix -> [Double] +mlist (M.Matrix a b c d e f) = [a,b,c,d,e,f] + +bracket :: (String -> IO ()) -> String -> String -> [a] -> (a -> IO ()) -> IO () +bracket f o c p g = + let h a = f a >> f " " + in h o >> mapM_ g p >> h c + +escape :: String -> String +escape = concatMap (\c -> if elem c "()" then ['\\', c] else [c]) + +put :: (String -> IO ()) -> PS -> IO () +put f (Name n) = f n >> f " " +put f (LName n) = f "/" >> f n >> f " " +put f (Op o) = f o >> f "\n" +put f (Comment o) = f "%" >> f o >> f "\n" +put f (Int n) = f (show n) >> f " " +put f (Double n) = f (show n) >> f " " +put f (String s) = f "(" >> f (escape s) >> f ") " +put f (Array a) = bracket f "[" "]" a (put f) +put f (Proc p) = bracket f "{" "}" p (put f) +put f (Matrix m) = put f (Array (map Double (mlist m))) +put f (Dict d) = + let g = concatMap (\(a,b) -> [a,b]) + in bracket f "<<" ">>" (g d) (put f) +put f (Seq a) = mapM_ (put f) a + +ps' :: (I.Image, Int) -> PS +ps' (p, n) = Seq [page "Graphics.PS" n, image p, showPage] + +paper_ps :: P.Paper -> P.Paper +paper_ps (P.Paper w h) = + let f n = floor (mm_pt (fromIntegral n)::Double) + in P.Paper (f w) (f h) + +ps :: String -> P.Paper -> [I.Image] -> IO () +ps f d p = do + h <- openFile f WriteMode + let g = put (hPutStr h) + (P.Paper width height) = paper_ps d + mapM_ g [ header + , title ("Graphics.PS: " ++ f) + , creator "Graphics.PS" + , languageLevel 2 + , pages (length p) + , documentMedia "Default" width height + , endComments + , prolog ] + mapM_ g (map ps' (zip p [1..])) + mapM_ g [ trailer + , eof] + hClose h + +{-- + +data Orientation = Portrait + | Landscape + deriving (Show) + +orientation :: Orientation -> PS +orientation o = dsc "Orientation" [show o] + +creationDate :: String -> PS +creationDate t = dsc "CreationDate" [t] + +setFont :: PS +setFont = Op "setfont" + +show :: String -> PS +show g = [String g, Op "h"] + +translate :: Double -> Double -> PS +translate x y = [Double x, Double y, Op "translate"] + +scale :: Double -> Double -> PS +scale x y = [Double x, Double y, Op "scale"] + +rotate :: Double -> PS +rotate a = [Double a, Op "rotate"] + +findFont :: Font -> PS +findFont (Font f _) = [LName f, Op "findfont"] + +scaleFont :: Font -> PS +scaleFont (Font _ n) = [Double n, Op "scalefont"] + +--} diff --git a/Graphics/PS/Paper.hs b/Graphics/PS/Paper.hs new file mode 100644 --- /dev/null +++ b/Graphics/PS/Paper.hs @@ -0,0 +1,69 @@ +module Graphics.PS.Paper where + +-- http://www.cl.cam.ac.uk/~mgk25/iso-paper.html + +-- | Paper size data type. +data Paper = Paper { width :: Int + , height :: Int } + deriving (Eq, Show) + +-- | Swap width and height. +landscape :: Paper -> Paper +landscape (Paper w h) = Paper h w + +-- | A div variant that rounds rather than truncates. +divRound :: Int -> Int -> Int +divRound x y = + let x' = (fromIntegral x)::Double + y' = (fromIntegral y)::Double + in round (x' / y') + +-- | ISO size downscaling. +iso_down_scale :: Paper -> Paper +iso_down_scale (Paper w h) = Paper (h `divRound` 2) w + +-- | ISO A sizes in millimeters. +a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, a10 :: Paper +a0 = Paper 841 1189 +a1 = iso_down_scale a0 +a2 = iso_down_scale a1 +a3 = iso_down_scale a2 +a4 = iso_down_scale a3 +a5 = iso_down_scale a4 +a6 = iso_down_scale a5 +a7 = iso_down_scale a6 +a8 = iso_down_scale a7 +a9 = iso_down_scale a8 +a10 = iso_down_scale a9 + +-- | ISO B sizes in millimeters. +b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, b10 :: Paper +b0 = Paper 1000 1414 +b1 = iso_down_scale b0 +b2 = iso_down_scale b1 +b3 = iso_down_scale b2 +b4 = iso_down_scale b3 +b5 = iso_down_scale b4 +b6 = iso_down_scale b5 +b7 = iso_down_scale b6 +b8 = iso_down_scale b7 +b9 = iso_down_scale b8 +b10 = iso_down_scale b9 + +-- | ISO C sizes in millimeters. +c0, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10 :: Paper +c0 = Paper 917 1297 +c1 = iso_down_scale c0 +c2 = iso_down_scale c1 +c3 = iso_down_scale c2 +c4 = iso_down_scale c3 +c5 = iso_down_scale c4 +c6 = iso_down_scale c5 +c7 = iso_down_scale c6 +c8 = iso_down_scale c7 +c9 = iso_down_scale c8 +c10 = iso_down_scale c9 + +-- | US Letter size in millimeters. +usLetter :: Paper +usLetter = Paper 216 279 diff --git a/Graphics/PS/Path.hs b/Graphics/PS/Path.hs new file mode 100644 --- /dev/null +++ b/Graphics/PS/Path.hs @@ -0,0 +1,145 @@ +module Graphics.PS.Path ( Path(..), (+++) + , line, polygon, rectangle + , arc, arcNegative, annular + , flatten ) where + +import Graphics.PS.Pt +import Graphics.PS.Matrix +import Graphics.PS.Glyph +import Graphics.PS.Font + +data Path = MoveTo Pt + | LineTo Pt + | CurveTo Pt Pt Pt + | Text Font [Glyph] + | PTransform Matrix Path + | Join Path Path + deriving (Eq, Show) + +-- | Infix notation for path join. +(+++) :: Path -> Path -> Path +(+++) = Join + +-- | Combine multiple paths. +combine :: [Path] -> Path +combine = foldl1 Join + +-- | Line segments though list of points. +line :: [Pt] -> Path +line (p:ps) = combine (MoveTo p : map LineTo ps) +line _ = error "line: illegal data" + +-- | Line variant connecting last point to first point. +polygon :: [Pt] -> Path +polygon (p:ps) = line (p:ps) `Join` LineTo p +polygon _ = error "polygon: illegal data" + +-- | Rectangle of specified dimensions anticlockwise from lower left. +rectangle :: Pt -> Double -> Double -> Path +rectangle (Pt x y) w h = + let ll = Pt x y + lr = Pt (x + w) y + ur = Pt (x + w) (y + h) + ul = Pt x (y + h) + in polygon [ll, lr, ur, ul] + +type ArcP = (Pt, Pt, Pt, Pt) +data Arc = Arc1 ArcP + | Arc2 ArcP ArcP + +-- (x,y) = center, r = radius, a = start angle, b = end angle +arcp :: Pt -> Double -> Double -> Double -> ArcP +arcp (Pt x y) r a b = + let ca = cos a + sa = sin a + cb = cos b + sb = sin b + bcp = 4 / 3 * (1 - cos ((b - a) / 2)) / sin ((b - a) / 2) + p0 = Pt (x + r * ca) (y + r * sa) + p1 = Pt (x + r * (ca - bcp * sa)) (y + r * (sa + bcp * ca)) + p2 = Pt (x + r * (cb + bcp * sb)) (y + r * (sb - bcp * cb)) + p3 = Pt (x + r * cb) (y + r * sb) + in (p0, p1, p2, p3) + +-- c = center, r = radius, a = start angle, b = end angle +-- if the arc angle is greater than pi the arc must be drawn in two +arca :: Pt -> Double -> Double -> Double -> Arc +arca c r a b = + let d = abs (b - a) + b' = b - (d / 2) + in if d > pi + then Arc2 (arcp c r a b') (arcp c r b' b) + else Arc1 (arcp c r a b) + +-- +arc' :: Arc -> Path +arc' (Arc1 (p0, p1, p2, p3)) = + let m = MoveTo p0 + c = CurveTo p1 p2 p3 + in m `Join` c +arc' (Arc2 (p0, p1, p2, p3) (_, p5, p6, p7)) = + let m = MoveTo p0 + c1 = CurveTo p1 p2 p3 + c2 = CurveTo p5 p6 p7 + in m `Join` c1 `Join` c2 + +-- | Arc given by a central point, a radius, and start and end angles. +arc :: Pt -> Double -> Double -> Double -> Path +arc c r a b = + let f n = if n < a then f (n + 2 * pi) else n + in arc' (arca c r a (f b)) + +-- | Negative arc. +arcNegative :: Pt -> Double -> Double -> Double -> Path +arcNegative c r a b = + let f n = if n > a then f (n - 2 * pi) else n + in arc' (arca c r (f b) a) + +-- (x,y) = center, ir = inner radius, xr = outer radius, sa = start +-- angle, a = angle, ea = end angle + +-- | Annular segment. +annular :: Pt -> Double -> Double -> Double -> Double -> Path +annular (Pt x y) ir xr sa a = + let ea = sa + a + x2 = x + ir * cos sa -- ll + y2 = y + ir * sin sa + x3 = x + xr * cos sa -- ul + y3 = y + xr * sin sa + x4 = x + ir * cos ea -- lr + y4 = y + ir * sin ea + in combine [MoveTo (Pt x2 y2) + ,LineTo (Pt x3 y3) + ,arc (Pt x y) xr sa ea + ,LineTo (Pt x4 y4) + ,arcNegative (Pt x y) ir ea sa] + +-- Perform transformations + +flatten' :: Matrix -> Path -> Path +flatten' m (MoveTo p) = MoveTo (ptTransform m p) +flatten' m (LineTo p) = LineTo (ptTransform m p) +flatten' m (PTransform m' p) = flatten' (m' * m) p +flatten' m (Join a b) = Join (flatten' m a) (flatten' m b) +flatten' m (CurveTo p q r) = + let f = ptTransform m + in CurveTo (f p) (f q) (f r) +flatten' _ (Text _ _) = error "cannot flatten text" + +flatten :: Path -> Path +flatten = flatten' identity + +{-- + +curve :: Pt -> Pt -> Pt -> Pt -> Path +curve p c1 c2 q = MoveTo p +++ CurveTo c1 c2 q + +-- | Polar variant. +pMoveTo :: Pt -> Path +pMoveTo p = MoveTo (polarToRectangular p) + +-- | Polar variant. +pLineTo :: Pt -> Path +pLineTo p = LineTo (polarToRectangular p) + +--} diff --git a/Graphics/PS/Pt.hs b/Graphics/PS/Pt.hs new file mode 100644 --- /dev/null +++ b/Graphics/PS/Pt.hs @@ -0,0 +1,72 @@ +module Graphics.PS.Pt ( Pt(Pt), + polarToRectangular, + ptMin, ptMax, ptXYs, origin, + ptTransform ) where + +import Graphics.PS.Matrix + +data Pt = Pt Double Double + deriving (Eq, Show) + +instance Num Pt where + negate (Pt x y) = Pt (- x) (- y) + Pt x0 y0 + Pt x1 y1 = Pt (x0 + x1) (y0 + y1) + Pt x0 y0 - Pt x1 y1 = Pt (x0 - x1) (y0 - y1) + Pt x0 y0 * Pt x1 y1 = Pt (x0 * x1) (y0 * y1) + abs (Pt x y) = Pt (abs x) (abs y) + signum _ = 0 + fromInteger a = let a' = fromInteger a + in Pt a' a' + +instance Ord Pt where + (Pt x0 y0) <= (Pt x1 y1) = x0 <= x1 && y0 <= y1 + +origin :: Pt +origin = Pt 0 0 + +ptXYs :: [Pt] -> [Double] +ptXYs [] = [] +ptXYs (Pt x y : ps) = x : y : ptXYs ps + +ptOp :: (Double -> Double -> Double) -> Pt -> Pt -> Pt +ptOp op (Pt x1 y1) (Pt x2 y2) = Pt (op x1 x2) (op y1 y2) + +ptMin :: Pt -> Pt -> Pt +ptMin = ptOp min + +ptMax :: Pt -> Pt -> Pt +ptMax = ptOp max + +polarToRectangular :: Pt -> Pt +polarToRectangular (Pt r t) = Pt (r * cos t) (r * sin t) + +ptTransform :: Matrix -> Pt -> Pt +ptTransform (Matrix a b c d e f) (Pt x y) = + let x' = x * a + y * c + e + y' = x * b + y * d + f + in Pt x' y' + +{-- + +pt :: (Double, Double) -> Pt +pt (x,y) = Pt x y + +ptX :: Pt -> Double +ptX (Pt x _) = x + +ptY :: Pt -> Double +ptY (Pt _ y) = y + +hypot :: (Floating a) => a -> a -> a +hypot x y = sqrt (x * x + y * y) + +distance :: Pt -> Pt -> Double +distance (Pt x1 y1) (Pt x2 y2) = hypot (x2 - x1) (y2 - y1) + +rectangularToPolar :: Pt -> Pt +rectangularToPolar (Pt x y) + | (x == 0) && (y == 0) = Pt 0 t + | otherwise = Pt (atan2 y x) t + where t = hypot x y + +--} diff --git a/Graphics/PS/Query.hs b/Graphics/PS/Query.hs new file mode 100644 --- /dev/null +++ b/Graphics/PS/Query.hs @@ -0,0 +1,83 @@ +module Graphics.PS.Query ( startPt, endPt + , mkValid + , approx, close ) where + +import Graphics.PS.Pt +import Graphics.PS.Bezier +import Graphics.PS.Path + +startPt :: Path -> Maybe Pt +startPt (MoveTo p) = Just p +startPt (Join p _) = startPt p +startPt _ = Nothing + +startPt' :: Path -> Maybe Pt +startPt' (MoveTo p) = Just p +startPt' (LineTo p) = Just p +startPt' (CurveTo p _ _) = Just p +startPt' (Join p _) = startPt' p +startPt' _ = Nothing + +mkValid :: Path -> Path +mkValid p = f (startPt' p) + where f (Just q) = MoveTo q +++ p + f Nothing = p + +endPt :: Path -> Maybe Pt +endPt (MoveTo p) = Just p +endPt (LineTo p) = Just p +endPt (CurveTo _ _ p) = Just p +endPt (Join _ p) = endPt p +endPt _ = Nothing + +close :: Path -> Path +close p = f (startPt p) + where f (Just q) = p +++ LineTo q + f Nothing = p + +-- | Approximate curves as straight lines. +approx :: Double -> Path -> Path +approx n (Join a (CurveTo p q r)) = + let is = [0, (1.0/n) .. 1.0] + f (Just p1) p2 p3 p4 = map (bezier4 p1 p2 p3 p4) is + f Nothing _ _ _ = [] + in a +++ line (f (endPt a) p q r) +approx _ p = p + +{-- + +data BBox = BBox Pt Pt + deriving (Eq, Show) + +import Graphics.PS.Transform + +bboxSum :: BBox -> BBox -> BBox +bboxSum (BBox a b) (BBox c d) = BBox (ptMin a c) (ptMax b d) + +bbox :: Path -> BBox +bbox (MoveTo p) = BBox p p +bbox (LineTo p) = BBox p p +bbox (Join a b) = bbox a `bboxSum` bbox b +bbox _ = error "illegal Query" + +join :: Path -> Path -> Path +join a b = a +++ translate x y b + where (Pt x y) = endPt a + +link :: Path -> Path -> Path +link a b = a +++ LineTo (startPt b) +++ b + +relMoveTo :: Path -> Pt -> Path +relMoveTo path (Pt dx dy) = path +++ MoveTo (Pt (x + dx) (y + dy)) + where (Pt x y) = endPt path + +relLineTo :: Path -> Pt -> Path +relLineTo path (Pt dx dy) = path +++ LineTo (Pt (x + dx) (y + dy)) + where (Pt x y) = endPt path + +hasText :: Path -> Bool +hasText (Join p1 p2) = hasText p1 || hasText p2 +hasText (Text _ _) = True +hasText _ = False + +--} diff --git a/Graphics/PS/Statistics.hs b/Graphics/PS/Statistics.hs new file mode 100644 --- /dev/null +++ b/Graphics/PS/Statistics.hs @@ -0,0 +1,20 @@ +module Graphics.PS.Statistics ( pathStatistics ) where + +import Graphics.PS.Path + +type Statistics = (Integer, Integer, Integer, Integer, Integer) + +plus :: Statistics -> Statistics -> Statistics +plus (m1, l1, c1, g1, t1) (m2, l2, c2, g2, t2) = + (m1 + m2, l1 + l2, c1 + c2, g1 + g2, t1 + t2) + +st :: Path -> Statistics +st (MoveTo _) = (1, 0, 0, 0, 0) +st (LineTo _) = (0, 1, 0, 0, 0) +st (CurveTo _ _ _) = (0, 0, 1, 0, 0) +st (Text _ s) = (0, 0, 0, fromIntegral (length s), 0) +st (PTransform _ p) = (0, 0, 0, 0, 1) `plus` st p +st (Join p1 p2) = st p1 `plus` st p2 + +pathStatistics :: Path -> Statistics +pathStatistics = st diff --git a/Graphics/PS/Transform.hs b/Graphics/PS/Transform.hs new file mode 100644 --- /dev/null +++ b/Graphics/PS/Transform.hs @@ -0,0 +1,37 @@ +module Graphics.PS.Transform (translate, scale, rotate) where + +import Graphics.PS.Matrix +import Graphics.PS.Pt +import qualified Graphics.PS.Path as P +import qualified Graphics.PS.Image as I + +class Transformable a where + transform :: Matrix -> a -> a + +translate :: (Transformable a) => Double -> Double -> a -> a +translate x = transform . translation x + +scale :: (Transformable a) => Double -> Double -> a -> a +scale x = transform . scaling x + +rotate :: (Transformable a) => Double -> a -> a +rotate = transform . rotation + +instance Transformable I.Image where + transform = I.ITransform + +instance Transformable P.Path where + transform = P.PTransform + +instance Transformable Pt where + transform = ptTransform + +{-- +import Graphics.PS.Pt + +-- | Polar variant. +pTranslate :: (Transform a) => Double -> Double -> a -> a +pTranslate r t = translate x y + where (Pt x y) = polarToRectangular (Pt r t) + +--} diff --git a/Graphics/PS/Unit.hs b/Graphics/PS/Unit.hs new file mode 100644 --- /dev/null +++ b/Graphics/PS/Unit.hs @@ -0,0 +1,32 @@ +module Graphics.PS.Unit (radians, mm_pt) where + +-- | Convert degrees to radians. +radians :: (Floating a) => a -> a +radians n = n / (360 / (2 * pi)) + +-- | Convert millimeters to PS points. +mm_pt :: (Floating a) => a -> a +mm_pt = (* 2.8346456664) + +{-- +-- | Convert PS points to millimeters. +pt_mm :: (Floating a) => a -> a +pt_mm = (/ 2.8346456664) + +-- | Postscript makes a point exactly 1/72 of an inch. +inch :: (Num a) => a -> a +inch n = 72 * n + +-- | 1 cm = 0.393700787 inches +cm :: (Floating a) => a -> a +cm n = 28.346456664 * n + +twopi :: (Floating a) => a +twopi = 2 * pi + +halfpi :: (Floating a) => a +halfpi = pi / 2 + +degrees :: (Floating a) => a -> a +degrees n = n * (360 / twopi) +--} diff --git a/Help/Animation.hs b/Help/Animation.hs new file mode 100644 --- /dev/null +++ b/Help/Animation.hs @@ -0,0 +1,75 @@ +module Animation where + +import System.Random +import Graphics.PS +import Graphics.PS.Cairo +import qualified Graphics.UI.Gtk as G +import Data.IORef + +data A = A Double Double Double Double + +semiann :: A -> Double -> Image +semiann (A gs ir xr a) sa = + let x = 250 + y = 250 + z = 250 + sa' = sa * 2.0 * pi + a' = a * pi + ir' = min ir xr + xr' = max ir xr + shift = translate x y . scale z z + in Fill (greyGS gs) (shift (annular origin ir' xr' sa' a')) + +-- | Group a list into a list of n element lists. +clump :: Int -> [a] -> [[a]] +clump _ [] = [] +clump n l = + let (i,j) = splitAt n l + in i : clump n j + +-- | Generate a list of n random numbers in the range [l,r]. +randn :: Int -> Int -> Double -> Double -> [Double] +randn s n l r = + let f i = i * (r - l) + l + in (map f . take n . randoms . mkStdGen) s + +-- +settings :: [(A, Double, Double)] +settings = + let g [a,b,c,d,e,f] = (A a b c d, e, f) + g _ = undefined + in map g (clump 6 (randn 0 66 0 1)) + +as :: [A] +as = map (\(a,_,_) -> a) settings + +ns :: [Double] +ns = map (\(_,n,_) -> n/100) settings + +is :: [Double] +is = map (\(_,_,i) -> i) settings + +main :: IO () +main = do + G.initGUI + window <- G.windowNew + canvas <- G.drawingAreaNew + ss <- newIORef is + G.windowSetResizable window False + G.widgetSetSizeRequest window 500 500 + G.onKeyPress window (const (G.widgetDestroy window >> return True)) + G.onDestroy window G.mainQuit + G.onExpose canvas (const (updateCanvas canvas ss)) + G.timeoutAdd (G.widgetQueueDraw window >> return True) 42 + G.set window [G.containerChild G.:= canvas] + G.widgetShowAll window + G.mainGUI + +updateCanvas :: G.DrawingArea -> IORef [Double] -> IO Bool +updateCanvas canvas ss = do + window <- G.widgetGetDrawWindow canvas + modifyIORef ss (zipWith (+) ns) + aa <- readIORef ss + let i = foldl1 over (zipWith semiann as aa) + G.renderWithDrawable window (renderImage i) + return True diff --git a/Help/Fractal.hs b/Help/Fractal.hs new file mode 100644 --- /dev/null +++ b/Help/Fractal.hs @@ -0,0 +1,45 @@ +module Fractal (fractal, fractalArrow, sierpinski) where + +import Graphics.PS + +-- | ftp://ftp.scsh.net/pub/scsh/contrib/fps/doc/examples/fractal-sqr.html +fractal :: Pt -> Pt -> Int -> [(Pt, Pt)] +fractal p1 p2 0 = [(p1, p2)] +fractal p1 p2 d = fractal p1 p3 (d - 1) ++ fractal p3 p2 (d - 1) + where (Pt x1 y1) = p1 + (Pt x2 y2) = p2 + x3 = ((x1 + x2) / 2) + ((y2 - y1) / 2) + y3 = ((y1 + y2) / 2) - ((x2 - x1) / 2) + p3 = Pt x3 y3 + +-- | ftp://ftp.scsh.net/pub/scsh/contrib/fps/doc/examples/fractal-arrow.html +fractalArrow :: Double -> Int -> Path +fractalArrow h d = (translate x y . scale h h) a + where x = (576 - h) / 2 + h / 2 + y = (720 - h) / 2 + a = unitArrow d + +unitArrow :: Int -> Path +unitArrow 1 = MoveTo (Pt 0 0) +++ LineTo (Pt 0 1) +unitArrow d = unitArrow 1 + +++ (translate 0 1 . rotate cw) sa + +++ (translate 0 1 . rotate ccw) sa + where s = 0.6 + sa = scale s s (unitArrow (d - 1)) + cw = - (radians 135) + ccw = - cw + +-- | Equilateral right angled triangle +erat :: Pt -> Double -> Path +erat (Pt x y) n = polygon [Pt x y, Pt (x+n) y, Pt x (y+n)] + +-- | Sierpinski triangle. +sierpinski :: Pt -> Double -> Double -> Path +sierpinski p n limit | n <= limit = erat p n + | otherwise = t1 +++ t2 +++ t3 + where m = n / 2 + (Pt x y) = p + s q = sierpinski q m limit + t1 = s p + t2 = s (Pt x (y + m)) + t3 = s (Pt (x + m) y) diff --git a/Help/HaskellPostScript.hs b/Help/HaskellPostScript.hs new file mode 100644 --- /dev/null +++ b/Help/HaskellPostScript.hs @@ -0,0 +1,165 @@ +import Fractal +import Graphics.PS hiding (a0, a1) +import Graphics.PS.Cairo +import System.Random +import Data.Maybe +import Data.List + +-- | Group a list into a list of n element lists. +clump :: Int -> [a] -> [[a]] +clump _ [] = [] +clump n l = i : clump n j where (i,j) = splitAt n l + +-- | Generate a list of n random numbers in the range [l,r]. +randn :: Int -> Int -> Double -> Double -> [Double] +randn s n l r = (map f . take n . randoms . mkStdGen) s + where f i = i * (r - l) + l + +-- | Grey fill operator. +gfill :: Double -> Path -> Image +gfill g = Fill (greyGS g) + +-- | Grey stroke operator. +gstroke :: Double -> Path -> Image +gstroke g = Stroke (greyGS g) + +-- | Crappy normalizer, ought to do bounds checks and take paper size. +normalize :: Path -> Path +normalize p = (translate s s . scale z z) p + where s = 250 + z = 250 + +-- Text is a path constructor. The first argument is a Font, the +-- second a list of Glyphs. Ordinarly a Text path is filled, however +-- it can be stroked as below. + +simpleText :: Image +simpleText = gstroke 0.25 t + where t = MoveTo (Pt 100 400) +++ Text (Font "Times" 72) "SimpleText" + +-- A random scattering of filled grey rectangles. + +rectangle_ :: [Double] -> Image +rectangle_ [g,x,y,z] = gfill g (shift (rectangle origin 1 1)) + where x' = x * 500 + y' = y * 500 + z' = z * 64 + shift = translate x' y' . scale z' z' +rectangle_ _ = error "illegal rectangle_" + +-- Angles in Hps are in radians and counter-clockwise. + +-- A Path must begin with a MoveTo operator. + +-- A random scattering of stroked arcs. arc makes a path composed of +-- bezier curves. + +semiarc :: [Double] -> Image +semiarc [g,x,y,z] = (gstroke g . shift . mkValid) (arc origin 1 0 (1.5 * pi)) + where x' = x * 500 + y' = y * 500 + z' = z * 64 + shift = translate x' y' . scale z' z' +semiarc _ = error "illegal semiarc" + +-- A random set of annular sections. annular makes a path composed of +-- arcs and lines. g = grey, ir = inner radius, xr = outer radius, sa +-- = start angle, a = angle. + +semiann :: (Double -> Path -> Image) -> [Double] -> Image +semiann f [g,ir,xr,sa,a] = f g $ shift $ mkValid $ annular origin ir' xr' sa' a' + where x = 250 + y = 250 + z = 250 + sa' = sa * 2.0 * pi + a' = a * pi + ir' = min ir xr + xr' = max ir xr + shift = translate x y . scale z z +semiann _ _ = error "illegal semiann" + +-- |flatten| applies all tranformations on a path generating a new +-- path. + +curve_ex :: Image +curve_ex = s 0 c `over` s 0.5 l + where p0 = Pt 0.1 0.5 + p1 = Pt 0.4 0.9 + p2 = Pt 0.6 0.1 + p3 = Pt 0.9 0.5 + c = MoveTo p0 +++ CurveTo p1 p2 p3 + l = MoveTo p0 +++ LineTo p1 +++ MoveTo p2 +++ LineTo p3 + s n = gstroke n . normalize + +startPt_ :: Path -> Pt +startPt_ = fromJust . startPt + +endPt_ :: Path -> Pt +endPt_ = fromJust . endPt + +--arcd_ex :: Image +arcd_ex :: (Pt -> Double -> Double -> Double -> Path) -> Image +arcd_ex arcd = s 0 e0 `over` f 0.9 e1 `over` s 0.5 e2 + where c = Pt 0.5 0.5 + r = 0.4 + a0 = radians 45 + a1 = radians 180 + e0 = mkValid $ arcd c r a0 a1 + e1 = mkValid $ arc c 0.05 0 (2 * pi) + e2 = MoveTo c +++ LineTo (startPt_ e0) +++ MoveTo c +++ LineTo (endPt_ e0) + s n = gstroke n . normalize + f n = gfill n . normalize + +path_ex' :: Path +path_ex' = MoveTo (Pt 0.5 0.1) + +++ LineTo (Pt 0.9 0.9) + +++ LineTo (Pt 0.5 0.9) + +++ CurveTo (Pt 0.2 0.9) (Pt 0.2 0.5) (Pt 0.5 0.5) + + +-- | Render each (p1, p2) as a distinct line. +renderLines :: [(Pt, Pt)] -> Path +renderLines = foldl f (MoveTo origin) + where f pth (p1, p2) = pth +++ MoveTo p1 +++ LineTo p2 + +-- | Collapse line sequences into a single line. +renderLinesO :: [(Pt, Pt)] -> Path +renderLinesO = foldl f (MoveTo origin) . snd . mapAccumL g origin + where g p (a,b) | p == a = (b, Right b) + | otherwise = (b, Left (a,b)) + f pth (Left (p1, p2)) = pth +++ MoveTo p1 +++ LineTo p2 + f pth (Right p2) = pth +++ LineTo p2 + +main :: IO () +main = + let rightAngles = renderLines (fractal (Pt 250 250) (Pt 175 175) 12) + rightAnglesO = renderLinesO (fractal (Pt 250 250) (Pt 175 175) 12) + arrows = fractalArrow 200 9 + rectangles = (foldl1 over . map rectangle_ . clump 4) (randn 1 240 0 1) + semiarcs = (foldl1 over . map semiarc . clump 4) (randn 1 120 0 1) + semiannsS = foldl1 over $ map (semiann gstroke) $ clump 5 $ randn 1 50 0 1 + semiannsF = foldl1 over $ map (semiann gfill) $ clump 5 $ randn 1 50 0 1 + arc_ex = arcd_ex arc + arcNegative_ex = arcd_ex arcNegative + path_ex = s 0 path_ex' + approx_ex n = s 0 (approx n path_ex') + fs_ex = s 0 e `over` f 0.9 e where e = close path_ex' + s n = gstroke n . normalize + f n = gfill n . normalize + in cg "test.ps" (Paper 900 600) [ gstroke 0 rightAngles + , gstroke 0 rightAnglesO + , gstroke 0 arrows + , gstroke 0 (flatten arrows) + , f 0 (sierpinski origin 0.5 0.01) + , simpleText + , rectangles + , semiarcs + , semiannsS + , semiannsF + , curve_ex + , arc_ex + , arcNegative_ex + , path_ex + , approx_ex 100 + , approx_ex 10 + , fs_ex ] diff --git a/Help/Screen.hs b/Help/Screen.hs new file mode 100644 --- /dev/null +++ b/Help/Screen.hs @@ -0,0 +1,33 @@ +module Screen where + +import Graphics.PS +import Graphics.PS.Cairo + +drawPath :: (GS -> a -> b) -> Double -> a -> b +drawPath m g p = m (greyGS g) p + +drawCircle :: Pt -> Double -> Image +drawCircle p r = + let c = arc p r 0 (2 * pi) + in drawPath Stroke 0.2 c + +drawRectangle :: Pt -> Double -> Double -> Double -> Image +drawRectangle p w h a = + let r = rectangle p w h + in drawPath Fill 0.4 (rotate a r) + +drawText :: Pt -> [Glyph] -> Double -> Image +drawText p t n = + let t' = Text (Font "Times" n) t + in drawPath Stroke 0.2 (MoveTo p +++ t') + +scena :: Double -> [Image] +scena n = + let p = Pt 250 250 + r = map (\a -> drawRectangle p 25 35 (pi/12*n*a)) [0..4] + in [ drawCircle p (25 * n) + , drawCircle p (65 * n) + , drawText p "Some text" (24 * n) ] ++ r + +main :: IO () +main = cg "test.ps" (Paper 900 600) (scena 1.0) diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,6 @@ +hps - haskell postscript + +partial and trivial postcript rendering + +(c) rohan drape 2006-2009 + gpl.2, http://gnu.org/copyleft/ diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/hps.cabal b/hps.cabal new file mode 100644 --- /dev/null +++ b/hps.cabal @@ -0,0 +1,40 @@ +Name: hps +Version: 0.1 +Synopsis: Haskell Postscript +Description: Haskell library partially implementing the + postscript drawing model. +License: GPL +Category: Graphics +Copyright: Rohan Drape, 2006-2009 +Author: Rohan Drape +Maintainer: rd@slavepianos.org +Stability: Experimental +Homepage: http://www.slavepianos.org/rd/f/972048/ +Tested-With: GHC == 6.8.2 +Build-Type: Simple +Cabal-Version: >= 1.6 + +Data-files: README + Help/Animation.hs + Help/Fractal.hs + Help/HaskellPostScript.hs + Help/Screen.hs + +Library + Build-Depends: base == 3.* + GHC-Options: -Wall -fwarn-tabs + Exposed-modules: Graphics.PS + Graphics.PS.Pt + Graphics.PS.Matrix + Graphics.PS.Bezier + Graphics.PS.Path + Graphics.PS.Glyph + Graphics.PS.Font + Graphics.PS.Image + Graphics.PS.Statistics + Graphics.PS.Transform + Graphics.PS.GS + Graphics.PS.Query + Graphics.PS.Paper + Graphics.PS.PS + Graphics.PS.Unit