packages feed

hps (empty) → 0.1

raw patch · 22 files changed

+1274/−0 lines, 22 filesdep +basesetup-changed

Dependencies added: base

Files

+ Graphics/PS.hs view
@@ -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
+ Graphics/PS/Bezier.hs view
@@ -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
+ Graphics/PS/Font.hs view
@@ -0,0 +1,4 @@+module Graphics.PS.Font (Font(..)) where++data Font = Font String Double+            deriving (Eq, Show)
+ Graphics/PS/GS.hs view
@@ -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+--}
+ Graphics/PS/Glyph.hs view
@@ -0,0 +1,3 @@+module Graphics.PS.Glyph (Glyph) where++type Glyph = Char
+ Graphics/PS/Image.hs view
@@ -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
+ Graphics/PS/Matrix.hs view
@@ -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+--}
+ Graphics/PS/PS.hs view
@@ -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"]++--}
+ Graphics/PS/Paper.hs view
@@ -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
+ Graphics/PS/Path.hs view
@@ -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)++--}
+ Graphics/PS/Pt.hs view
@@ -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++--}
+ Graphics/PS/Query.hs view
@@ -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++--}
+ Graphics/PS/Statistics.hs view
@@ -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
+ Graphics/PS/Transform.hs view
@@ -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)++--}
+ Graphics/PS/Unit.hs view
@@ -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)+--}
+ Help/Animation.hs view
@@ -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
+ Help/Fractal.hs view
@@ -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)
+ Help/HaskellPostScript.hs view
@@ -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 ]
+ Help/Screen.hs view
@@ -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)
+ README view
@@ -0,0 +1,6 @@+hps - haskell postscript++partial and trivial postcript rendering++(c) rohan drape 2006-2009+    gpl.2, http://gnu.org/copyleft/
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ hps.cabal view
@@ -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