hps 0.2 → 0.11

raw patch · 25 files changed

+721/−578 lines, 25 filesdep +directorydep +filepathdep +randomsetup-changednew-component:exe:hps-fractalsPVP ok

version bump matches the API change (PVP)

Dependencies added: directory, filepath, random

API changes (from Hackage documentation)

Files

• Graphics/PS.hs +1/−0
• Graphics/PS/Bezier.hs +6/−5
• Graphics/PS/Font.hs +4/−3
• Graphics/PS/GS.hs +18/−11
• Graphics/PS/Glyph.hs +1/−0
• Graphics/PS/Image.hs +26/−9
• Graphics/PS/Matrix.hs +26/−29
• Graphics/PS/PS.hs +116/−68
• Graphics/PS/Paper.hs +58/−13
• Graphics/PS/Path.hs +75/−41
• Graphics/PS/Path/Graphs.hs +66/−0
• Graphics/PS/Pt.hs +15/−11
• Graphics/PS/Query.hs +53/−36
• Graphics/PS/Statistics.hs +22/−20
• Graphics/PS/Transform.hs +7/−1
• Graphics/PS/Unit.hs +1/−0
• Help/Animation.hs +0/−75
• Help/Fractal.hs +0/−45
• Help/HaskellPostScript.hs +0/−165
• Help/Screen.hs +0/−33
• Help/fractals.hs +204/−0
• README +3/−1
• Setup.hs +3/−0
• Setup.lhs +0/−3
• hps.cabal +16/−9

@@ -1,3 +1,4 @@+-- | Top-level module for @hps@. module Graphics.PS (module Graphics.PS.Pt,                     module Graphics.PS.Bezier,                     module Graphics.PS.Path,

@@ -1,3 +1,4 @@+-- | Bezier functions. module Graphics.PS.Bezier (bezier4) where  import Graphics.PS.Pt@@ -5,14 +6,14 @@ {-- bezier3 :: Pt -> Pt -> Pt -> Double -> Pt bezier3 (Pt x1 y1) (Pt x2 y2) (Pt x3 y3) mu = (Pt x y)-    where a = mu * mu+    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+          c = b*b+          x = x1*c + 2*x2*b*mu + x3*a+          y = y1*c + 2*y2*b*mu + y3*a --} --- | Four-point bezier curve interpolation.  The index (mu) is+-- | Four-point bezier curve interpolation.  The index /mu/ is --   in the range zero to one. bezier4 :: Pt -> Pt -> Pt -> Pt -> Double -> Pt bezier4 (Pt x1 y1) (Pt x2 y2) (Pt x3 y3) (Pt x4 y4) mu =

@@ -1,6 +1,7 @@+-- | Font type and functions. module Graphics.PS.Font (Font(..)) where  -- | Font data type.-data Font = Font { fontName :: String-                 , fontSize :: Double }-            deriving (Eq, Show)+data Font = Font {fontName :: String+                 ,fontSize :: Double}+            deriving (Eq,Show)

@@ -1,32 +1,39 @@-module Graphics.PS.GS ( GS(..)-                      , LineCap(..)-                      , LineJoin(..)-                      , Color(..)-                      , defaultGS, greyGS ) where+-- | PS graphics state.+module Graphics.PS.GS (GS(..)+                      ,LineCap(..)+                      ,LineJoin(..)+                      ,LineWidth+                      ,Color(..)+                      ,defaultGS, greyGS) where -data LineCap = ButtCap -             | RoundCap +-- | Line cap enumeration.+data LineCap = ButtCap+             | RoundCap              | ProjectingSquareCap                deriving (Eq, Show, Enum) +-- | Line width (real). type LineWidth = Double -data LineJoin = MiterJoin -              | RoundJoin +-- | Line join enumeration.+data LineJoin = MiterJoin+              | RoundJoin               | BevelJoin                 deriving (Eq, Show, Enum) +-- | Colour model. data Color = RGB Double Double Double              deriving (Eq, Show) +-- | Graphics state. data GS = GS Color LineWidth LineCap LineJoin ([Int], Int) Double           deriving (Eq, Show) --- | Default GS of indicated color.+-- | Default 'GS' of indicated 'Color'. defaultGS :: Color -> GS defaultGS c = GS c 1.0 ButtCap MiterJoin ([], 0) 10.0 --- | Default GS of indicated shade of grey.+-- | Default 'GS' of indicated shade of grey. greyGS :: Double -> GS greyGS g = defaultGS (RGB g g g) 

@@ -1,3 +1,4 @@+-- | Glyph data type. module Graphics.PS.Glyph (Glyph) where  -- | Character data type.

@@ -1,17 +1,34 @@-module Graphics.PS.Image (Image(..), over) where+-- | Image type and functions.+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+import Graphics.PS.Matrix+import Graphics.PS.Path+import Graphics.PS.GS --- | Image data type.-data Image = Stroke G.GS P.Path-           | Fill G.GS P.Path-           | ITransform M.Matrix Image+-- | An image is a rendering of a graph of 'Path's.+data Image = Stroke GS Path+           | Fill GS Path+           | ITransform Matrix Image            | Over Image Image            | Empty              deriving (Eq, Show) --- | Layer one image over another.+-- | Layer one 'Image' over another. over :: Image -> Image -> Image over = Over++{-+-- | Apply a function to leaf nodes.+i_apply :: (Image -> Image) -> Image -> Image+i_apply f (ITransform m i) = ITransform m (i_apply f i)+i_apply f (Over i j) = Over (i_apply f i) (i_apply f j)+i_apply f i = f i++-- | Apply a path function to leaf nodes.+i_p_apply :: (P.Path -> P.Path) -> Image -> Image+i_p_apply f (Stroke g p) = Stroke g (P.p_apply f p)+i_p_apply f (Fill g p) = Fill g (P.p_apply f p)+i_p_apply f (ITransform m i) = ITransform m (i_p_apply f i)+i_p_apply f (Over i j) = Over (i_p_apply f i) (i_p_apply f j)+i_p_apply _ Empty = Empty+-}

@@ -1,43 +1,40 @@-module Graphics.PS.Matrix ( Matrix(Matrix)-                          , identity-                          , translation, scaling, rotation ) where+-- | Matrix type and functions.+module Graphics.PS.Matrix (R,Matrix(Matrix)+                          ,identity+                          ,translation,scaling,rotation) where +-- | Synonym for 'Double'. type R = Double  -- | Transformation matrix data type.-data Matrix = Matrix R R R R R R-              deriving (Eq, Show)--type M = Matrix+data Matrix = Matrix R R R R R R deriving (Eq,Show) -data MIx = I0 -            | I1 -            | I2 -              deriving (Eq, Show, Enum)+-- | Enumeration of 'Matrix' indices.+data Matrix_Index = I0 | I1 | I2 -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)+row :: Matrix -> Matrix_Index -> (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)+col :: Matrix -> Matrix_Index -> (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 :: Matrix -> Matrix -> Matrix multiply a b =-    let f i j = let (r1, r2, r3) = row a i-                    (c1, c2, c3) = col b j+    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 :: (R -> R) -> Matrix -> Matrix 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 :: (R -> R -> R) -> Matrix -> Matrix -> Matrix 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') @@ -48,18 +45,18 @@     abs = pointwise abs     signum = pointwise signum     fromInteger n = let n' = fromInteger n-                    in Matrix n' 0 0 n' 0 0 +                    in Matrix n' 0 0 n' 0 0  -- | A translation matrix with independent x and y offsets.-translation :: R -> R -> M+translation :: R -> R -> Matrix translation = Matrix 1 0 0 1  -- | A scaling matrix with independent x and y scalars.-scaling :: R -> R -> M+scaling :: R -> R -> Matrix scaling x y = Matrix x 0 0 y 0 0  -- | A rotation matrix through the indicated angle (in radians).-rotation :: R -> M+rotation :: R -> Matrix rotation a =     let c = cos a         s = sin a@@ -67,7 +64,7 @@     in Matrix c s t c 0 0  -- | The identity matrix.-identity :: M+identity :: Matrix identity = Matrix 1 0 0 1 0 0  {--

@@ -1,4 +1,5 @@-module Graphics.PS.PS (ps) where+-- | Postscript generator.+module Graphics.PS.PS (ps,eps,stringFromPS) where  import Graphics.PS.Pt import qualified Graphics.PS.Matrix as M@@ -10,26 +11,29 @@ import qualified Graphics.PS.Image as I import Data.List import System.IO+import Data.Monoid (Monoid, mappend, mempty, mconcat, Endo(Endo,appEndo), ) -data PS = Name    String-        | LName   String-        | Op      String++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]+        | 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,headerEps :: PS header = Comment "!PS-Adobe-3.0"+headerEps = Comment "!PS-Adobe-3.0 EPSF-3.0"  title :: String -> PS title t = dsc "Title" [t]@@ -43,6 +47,12 @@ pages :: Int -> PS pages n = dsc "Pages" [show n] +bbox :: P.BBox -> PS+bbox (P.BBox i j k l) = dsc "BoundingBox" [show i,show j,show k,show l]+bbox (P.HRBBox i j k l i' j' k' l') =+    Seq [dsc "BoundingBox" [show i,show j,show k,show l],+         dsc "HiResBoundingBox" [show i',show j',show k',show l']]+ endComments :: PS endComments = dsc "EndComments" [] @@ -96,10 +106,10 @@ false = Name "false"  save :: PS-save = Seq [Op "matrix", Op "currentmatrix"]+save = Op "q"  restore :: PS-restore = Op "setmatrix"+restore = Op "Q"  showPage :: PS showPage = Op "showpage"@@ -134,6 +144,9 @@ curveTo :: Pt -> Pt -> Pt -> PS curveTo a b c = Seq (map Double (ptXYs [a,b,c]) ++ [Op "c"]) +closePath :: Pt -> PS+closePath (Pt x y) = Seq [Double x, Double y, Op "h"]+ selectFont :: Font -> PS selectFont (Font f n) = Seq [LName f, Double n, Op "Tf"] @@ -141,60 +154,65 @@ 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 ]+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 (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]+path (ClosePath p) = closePath p+path (PTransform m p) = Seq [transform m, path p]+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]+image (I.ITransform m i) = Seq [transform m, image i]+image (I.Over a b) = Seq [save+                         ,image b+                         ,restore+                         ,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 +infixl 1 >+> +(>+>) :: Monoid m => m -> m -> m+(>+>) = mappend++bracket :: (Monoid m) =>+    (String -> m) -> String -> String -> [a] -> (a -> m) -> m+bracket f o c p g =+    let h a = f a >+> f " "+    in h o >+> mconcat (map 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)    = +put :: (Monoid m) => (String -> m) -> PS -> m+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+    in bracket f "<<" ">>" (g d) (put f)+put f (Seq a) = mconcat (map (put f) a)  ps' :: (I.Image, Int) -> PS ps' (p, n) = Seq [page "Graphics.PS" n,  image p, showPage]@@ -206,23 +224,53 @@  -- | Write a postscript file.  The list of images are written --   one per page.-ps :: String -> P.Paper -> [I.Image] -> IO ()-ps f d p = do -  h <- openFile f WriteMode-  let g = put (hPutStr h)+ps :: FilePath -> P.Paper -> [I.Image] -> IO ()+ps f d p =+  writeFile f (stringFromPS f d p)++-- | Generate postscript data given /title/, page size, and a set of+-- page 'I.Images'.+stringFromPS :: String -> P.Paper -> [I.Image] -> String+stringFromPS t d p =+  let g = put (\s -> Endo (s++))       (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+  in  flip appEndo "" $+      g header >+>+      g (title t) >+>+      g (creator "Graphics.PS") >+>+      g (languageLevel 2) >+>+      g (pages (length p)) >+>+      g (documentMedia "Default" width height) >+>+      g endComments >+>+      g prolog >+>+      mconcat (map (g . ps') (zip p [1..])) >+>+      g trailer >+>+      g eof+++newtype MonadMonoid m = MonadMonoid {appMonadMonoid :: m ()}++instance Monad m => Monoid (MonadMonoid m) where+   mempty = MonadMonoid (return ())+   mappend (MonadMonoid a) (MonadMonoid b) =+      MonadMonoid (a >> b)+   mconcat = MonadMonoid . mapM_ appMonadMonoid++-- | Write an encapsulated postscript file.  The single image+--   is written.+eps :: String -> P.BBox -> I.Image -> IO ()+eps f d p =+  withFile f WriteMode $ \h ->+     let g = put (MonadMonoid . hPutStr h)+     in  mapM_ (appMonadMonoid . g) $+            [headerEps+            ,title ("Graphics.PS: " ++ f)+            ,creator "Graphics.PS"+            ,languageLevel 2+            ,bbox d+            ,endComments+            ,prolog+            ,image p]  {-- 

@@ -1,29 +1,53 @@+-- | Paper sizes.+-- For ISO sizes see <http://www.cl.cam.ac.uk/~mgk25/iso-paper.html>. 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)+data Paper = Paper {width :: Int+                   ,height :: Int}+             deriving (Eq,Show) --- | Swap width and height.+-- | BoundingBox for an EPSF file with an optional HiResBoundingBox+data BBox = BBox {llx :: Int -- ^ lower left x (x-min)+                 ,lly :: Int -- ^ lower left y (y-min)+                 ,urx :: Int -- ^ upper right x (x-max)+                 ,ury :: Int -- ^ upper right y (y-max)+                 }+          | HRBBox {llx :: Int+                   ,lly :: Int+                   ,urx :: Int+                   ,ury :: Int+                   ,hrllx :: Double -- ^ high resolution 'llx'+                   ,hrlly :: Double -- ^ high resolution 'lly'+                   ,hrurx :: Double -- ^ high resolution 'urx'+                   ,hrury :: Double -- ^ high resolution 'ury'+                   }+            deriving (Eq,Show)++-- | Swap width and height of 'Paper'. landscape :: Paper -> Paper landscape (Paper w h) = Paper h w --- | A div variant that rounds rather than truncates.+-- | A 'div' variant that rounds rather than truncates.+--+-- > let f (Paper _ h) = h `div` 2 == h `divRound` 2+-- > in all id (map f [b0,b1,b2,b3,b4,b5,b6,b7,b8,b9]) == False divRound :: Int -> Int -> Int-divRound x y = +divRound x y =     let x' = (fromIntegral x)::Double         y' = (fromIntegral y)::Double     in round (x' / y') --- | ISO size downscaling.+-- | ISO size downscaling, ie. from @A0@ to @A1@.+--+-- > iso_down_scale a4 == a5 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+--+-- > a4 == Paper 210 297+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@@ -37,7 +61,9 @@ a10 = iso_down_scale a9  -- | ISO B sizes in millimeters.-b0, b1, b2, b3, b4, b5, b6, b7, b8, b9, b10 :: Paper+--+-- > b4 == Paper 250 354+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@@ -51,7 +77,9 @@ b10 = iso_down_scale b9  -- | ISO C sizes in millimeters.-c0, c1, c2, c3, c4, c5, c6, c7, c8, c9, c10 :: Paper+--+-- > c4 == Paper 229 324+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@@ -64,6 +92,23 @@ c9 = iso_down_scale c8 c10 = iso_down_scale c9 --- | US Letter size in millimeters.+-- | US Letter size in millimeters (ie 'Paper' @216 279@). usLetter :: Paper usLetter = Paper 216 279++-- | Newspaper sizes in millimeters.+-- See <http://www.papersizes.org/newspaper-sizes.htm>.+broadsheet,berliner,tabloid :: Paper+broadsheet = Paper 600 750+berliner = Paper 315 470+tabloid = Paper 280 430++-- | Proportion of 'Paper'.+--+-- > proportion broadsheet == 1.25+-- > map (round . (* 1e3) . proportion) [a0,b0,c0] == [1414,1414,1414]+-- > map proportion [usLetter,berliner,tabloid]+proportion :: Paper -> Double+proportion p =+    let f = fromIntegral+    in f (height p) / f (width p)

@@ -1,54 +1,63 @@-module Graphics.PS.Path ( Path(..), (+++)-                        , line, polygon, rectangle-                        , arc, arcNegative, annular-                        , flatten ) where+-- | Path type and functions.+module Graphics.PS.Path (Path(..),(+++)+                        ,line,polygon,rectangle+                        ,arc,arcNegative,annular+                        ,flatten+                        ,renderLines,renderLines') where +import Data.List import Graphics.PS.Pt import Graphics.PS.Matrix import Graphics.PS.Glyph import Graphics.PS.Font --- | Path data type, in cartesian space.+-- | Path data type,in cartesian space. data Path = MoveTo Pt           | LineTo Pt           | CurveTo Pt Pt Pt+          | ClosePath Pt           | Text Font [Glyph]           | PTransform Matrix Path           | Join Path Path-            deriving (Eq, Show)+            deriving (Eq,Show) --- | Infix notation for path join.+-- | Infix notation for 'Join'. (+++) :: Path -> Path -> Path (+++) = Join --- | Combine multiple paths.+-- | Left fold of 'Join'. combine :: [Path] -> Path combine = foldl1 Join --- | Line segments though list of points.+-- | Line segments though list of 'Pt'. line :: [Pt] -> Path-line (p:ps) = combine (MoveTo p : map LineTo ps)-line _ = error "line: illegal data"+line x =+    case x of+      [] -> error "line: illegal data"+      (p:ps) -> combine (MoveTo p : map LineTo ps) --- | Line variant connecting last point to first point.+-- | Variant of 'line' connecting the last 'Pt' to the first. polygon :: [Pt] -> Path-polygon (p:ps) = line (p:ps) `Join` LineTo p-polygon _ = error "polygon: illegal data"+polygon x =+    case x of+      [] -> error "polygon: illegal data"+      (p:ps) -> line (p:ps) +++ ClosePath p --- | Rectangle of specified dimensions anticlockwise from lower left.+-- | Rectangle with lower left at 'Pt' and of specified width and+-- height.  Polygon is oredered 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]+    in polygon [ll,lr,ur,ul] -type ArcP = (Pt, Pt, Pt, Pt)-data Arc  = Arc1 ArcP -          | Arc2 ArcP ArcP+type ArcP = (Pt,Pt,Pt,Pt)+data Arc = Arc1 ArcP+         | Arc2 ArcP ArcP --- (x,y) = center, r = radius, a = start angle, b = end angle+-- (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@@ -60,31 +69,31 @@         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)+    in (p0,p1,p2,p3) --- c = center, r = radius, a = start angle, b = end angle+-- 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 +    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)) =+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)) =+    in m +++ 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+    in m +++ c1 +++ c2 --- | Arc given by a central point, a radius, and start and end angles.+-- | 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@@ -92,16 +101,16 @@  -- | Negative arc. arcNegative :: Pt -> Double -> Double -> Double -> Path-arcNegative c r a b = +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+-- (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 = +annular (Pt x y) ir xr sa a =     let ea = sa + a         x2 = x + ir * cos sa -- ll         y2 = y + ir * sin sa@@ -116,20 +125,39 @@                ,arcNegative (Pt x y) ir ea sa]  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' m path =+    case path of+      MoveTo p -> MoveTo (ptTransform m p)+      LineTo p -> LineTo (ptTransform m p)+      ClosePath p -> ClosePath (ptTransform m p)+      PTransform m' p -> flatten' (m' * m) p+      Join a b -> Join (flatten' m a) (flatten' m b)+      CurveTo p q r -> let f = ptTransform m+                       in CurveTo (f p) (f q) (f r)+      Text _ _ -> error "cannot flatten text"  -- | Apply any transformations at path.  The resulting path will not---   have any transformation nodes.+--   have any 'PTransform' nodes. flatten :: Path -> Path flatten = flatten' identity +-- | Render each (p1,p2) as a distinct line.+renderLines :: [(Pt,Pt)] -> Path+renderLines =+    let f pth (p1,p2) = pth +++ MoveTo p1 +++ LineTo p2+    in foldl f (MoveTo origin)++-- | Collapse line sequences into a single line.+renderLines' :: [(Pt,Pt)] -> Path+renderLines' =+    let g p (a,b) = if p == a+                    then (b,Right b)+                    else (b,Left (a,b))+        f path e = case e of+                     Left (p1,p2) -> path +++ MoveTo p1 +++ LineTo p2+                     Right p2 -> path +++ LineTo p2+    in foldl f (MoveTo origin) . snd . mapAccumL g origin+ {--  curve :: Pt -> Pt -> Pt -> Pt -> Path@@ -142,5 +170,11 @@ -- | Polar variant. pLineTo :: Pt -> Path pLineTo p = LineTo (polarToRectangular p)++-- | Apply a funtion to leaf nodes.+p_apply :: (Path -> Path) -> Path -> Path+p_apply f (Join p q) = Join (f p) (f q)+p_apply f (PTransform m p) = PTransform m (f p)+p_apply f p = f p  --}

@@ -0,0 +1,66 @@+-- | Set of predefined 'Path's.+module Graphics.PS.Path.Graphs where++import Graphics.PS.Path+import Graphics.PS.Pt+import Graphics.PS.Transform+import Graphics.PS.Unit++-- | See <ftp.scsh.net/pub/scsh/contrib/fps/doc/examples/fractal-sqr.html>+fractal_sqr_pt :: Pt -> Pt -> Int -> [(Pt,Pt)]+fractal_sqr_pt p1 p2 d =+    case d of+      0 -> [(p1,p2)]+      _ -> let (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+           in fractal_sqr_pt p1 p3 (d - 1) ++ fractal_sqr_pt p3 p2 (d - 1)++-- | 'Path' of 'fractal_sqr_pt' with inputs @(250,250)@, @(175,175)@, @12@.+fractal_sqr :: Path+fractal_sqr = renderLines (fractal_sqr_pt (Pt 250 250) (Pt 175 175) 12)++-- | 'renderLines'' variant of 'fractal_sqr'.+fractal_sqr' :: Path+fractal_sqr' = renderLines' (fractal_sqr_pt (Pt 250 250) (Pt 175 175) 12)++-- | A /unit/ arrow.+unitArrow :: Int -> Path+unitArrow d =+    case d of+      1 -> MoveTo (Pt 0 0) +++ LineTo (Pt 0 1)+      _ -> let s = 0.6+               sa = scale s s (unitArrow (d - 1))+               cw = negate (radians 135)+               ccw = negate cw+           in unitArrow 1 ++++              (translate 0 1 . rotate cw) sa ++++              (translate 0 1 . rotate ccw) sa++-- | See <ftp.scsh.net/pub/scsh/contrib/fps/doc/examples/fractal-arrow.html>+fractalArrow :: Double -> Int -> Path+fractalArrow h d =+    let x = (576 - h) / 2 + h / 2+        y = (720 - h) / 2+        a = unitArrow d+    in (translate x y . scale h h) a++-- | Isosceles 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 =+    let 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)+    in if n <= limit+       then erat p n+       else t1 +++ t2 +++ t3+

@@ -1,23 +1,24 @@-module Graphics.PS.Pt ( Pt(Pt), -                        polarToRectangular, -                        ptMin, ptMax, ptXYs, origin, -                        ptTransform ) where+-- | Point type and associated functions.+module Graphics.PS.Pt (Pt(Pt)+                      ,polarToRectangular+                      ,ptMin, ptMax, ptXYs, origin+                      ,ptTransform) where  import Graphics.PS.Matrix --- | Point data type, component values are real.+-- | Cartesian co-ordinate with real valued /x/ and /y/ fields. data Pt = Pt Double Double           deriving (Eq, Show)  instance Num Pt where-    negate (Pt x y)     = Pt (- x) (- y)+    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'+    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@@ -26,6 +27,7 @@ origin :: Pt origin = Pt 0 0 +-- | /x/ and /y/ elements of a set of 'Pt's. ptXYs :: [Pt] -> [Double] ptXYs [] = [] ptXYs (Pt x y : ps) = x : y : ptXYs ps@@ -33,9 +35,11 @@ ptOp :: (Double -> Double -> Double) -> Pt -> Pt -> Pt ptOp op (Pt x1 y1) (Pt x2 y2) = Pt (op x1 x2) (op y1 y2) +-- | 'Pt' at /x/ and /y/ minima of inputs. ptMin :: Pt -> Pt -> Pt ptMin = ptOp min +-- | 'Pt' at /x/ and /y/ maxima of inputs. ptMax :: Pt -> Pt -> Pt ptMax = ptOp max @@ -70,7 +74,7 @@ rectangularToPolar :: Pt -> Pt rectangularToPolar (Pt x y)     | (x == 0) && (y == 0) = Pt 0 t-    | otherwise            = Pt (atan2 y x) t+    | otherwise = Pt (atan2 y x) t     where t = hypot x y  --}

@@ -1,52 +1,69 @@-module Graphics.PS.Query ( startPt, endPt-                         , mkValid-                         , approx, close ) where+-- | 'Path' query functions and related operations.+module Graphics.PS.Query (startPt, endPt+                         ,mkValid+                         ,approx, close) where  import Graphics.PS.Pt import Graphics.PS.Bezier import Graphics.PS.Path --- | Locate the starting point of the path.+-- | Locate the starting point of the path, which must begin with a+-- 'MoveTo' node. startPt :: Path -> Maybe Pt-startPt (MoveTo p) = Just p-startPt (Join p _) = startPt p-startPt _ = Nothing+startPt path =+    case path of+      MoveTo p -> Just p+      Join p _ -> startPt p+      _ -> Nothing +-- | Variant that allows the initial node to be a 'LineTo' or+-- 'CurveTo' node. 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+startPt' path =+    case path of+      MoveTo p -> Just p+      LineTo p -> Just p+      CurveTo p _ _ -> Just p+      Join p _ -> startPt' p+      _ -> Nothing --- | Ensure path begins with a MoveTo.+-- | Ensure path begins with a 'MoveTo' node. mkValid :: Path -> Path-mkValid p = f (startPt' p)-    where f (Just q) = MoveTo q +++ p-          f Nothing = p+mkValid path =+    case startPt' path of+      Just p -> MoveTo p +++ path+      Nothing -> path  -- | Locate the end point of the path. 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+endPt path =+    case path of+      MoveTo p -> Just p+      LineTo p -> Just p+      CurveTo _ _ p -> Just p+      Join _ p -> endPt p+      _ -> Nothing --- | Add a LineTo the start point of path.+-- | Append a 'LineTo' the start point of 'Path'. close :: Path -> Path-close p = f (startPt p)-    where f (Just q) = p +++ LineTo q-          f Nothing = p+close path =+    case startPt path of+      Just p -> path +++ ClosePath p+      Nothing -> path --- | Approximate curves as straight lines.+-- | Approximate curves as /n/ straight line segments.  That is+-- replace 'CurveTo' nodes with /n/ 'LineTo' nodes calculated using+-- 'bezier4'. 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+approx n path =+    case path of+      Join a (CurveTo p2 p3 p4) ->+          let is = [0, (1.0/n) .. 1.0]+              l = case endPt a of+                    Just p1 -> map (bezier4 p1 p2 p3 p4) is+                    Nothing -> []+          in a +++ line l+      _ -> path  {-- @@ -59,10 +76,10 @@ 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"+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

@@ -1,30 +1,32 @@-module Graphics.PS.Statistics ( Statistics(..)-                              , pathStatistics ) where+-- | 'Path' statistics.+module Graphics.PS.Statistics (Statistics(..)+                              ,pathStatistics) where  import Graphics.PS.Path  -- | Path statistics data type.-data Statistics = Statistics {-      nMoveTo :: Integer-    , nLineTo :: Integer-    , nCurveTo :: Integer-    , nGlyph :: Integer-    , nTransform :: Integer }+data Statistics = Statistics {nMoveTo :: Integer+                             ,nLineTo :: Integer+                             ,nCurveTo :: Integer+                             ,nClosePath :: Integer+                             ,nGlyph :: Integer+                             ,nTransform :: Integer}  plus :: Statistics -> Statistics -> Statistics plus p q =-    let (Statistics m1 l1 c1 g1 t1) = p-        (Statistics m2 l2 c2 g2 t2) = q-    in Statistics (m1 + m2) (l1 + l2) (c1 + c2) (g1 + g2) (t1 + t2)--st :: Path -> Statistics-st (MoveTo _) = Statistics 1 0 0 0 0-st (LineTo _) = Statistics 0 1 0 0 0-st (CurveTo _ _ _) = Statistics 0 0 1 0 0-st (Text _ s) = Statistics 0 0 0 (fromIntegral (length s)) 0-st (PTransform _ p) = Statistics 0 0 0 0 1 `plus` st p-st (Join p1 p2) = st p1 `plus` st p2+    let (Statistics m1 l1 c1 f1 g1 t1) = p+        (Statistics m2 l2 c2 f2 g2 t2) = q+    in Statistics (m1+m2) (l1+l2) (c1+c2) (f1+f2) (g1+g2) (t1+t2)  -- | Determine number of path components of each type. pathStatistics :: Path -> Statistics-pathStatistics = st+pathStatistics path =+    case path of+      MoveTo _ -> Statistics 1 0 0 0 0 0+      LineTo _ -> Statistics 0 1 0 0 0 0+      CurveTo _ _ _ -> Statistics 0 0 1 0 0 0+      ClosePath _ -> Statistics 0 0 0 1 0 0+      Text _ s -> Statistics 0 0 0 0 (fromIntegral (length s)) 0+      PTransform _ p -> Statistics 0 0 0 0 0 1 `plus` pathStatistics p+      Join p1 p2 -> pathStatistics p1 `plus` pathStatistics p2+

@@ -1,19 +1,25 @@-module Graphics.PS.Transform (translate, scale, rotate) where+-- | Class and associated functions for 'Matrix' transformations.+module Graphics.PS.Transform (Transformable+                             ,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 +-- | Values that can be transformed in relation to a 'Matrix'. class Transformable a where     transform :: Matrix -> a -> a +-- | Translation in /x/ and /y/. translate :: (Transformable a) => Double -> Double -> a -> a translate x = transform . translation x +-- | Scaling in /x/ and /y/. scale :: (Transformable a) => Double -> Double -> a -> a scale x = transform . scaling x +-- | Rotation, in radians. rotate :: (Transformable a) => Double -> a -> a rotate = transform . rotation 

@@ -1,3 +1,4 @@+-- | Unit definitions and conversions. module Graphics.PS.Unit (radians, mm_pt) where  -- | Convert degrees to radians.

@@ -1,75 +0,0 @@-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

@@ -1,45 +0,0 @@-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)

@@ -1,165 +0,0 @@-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 ]

@@ -1,33 +0,0 @@-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)

@@ -0,0 +1,204 @@+module Main where++import Data.Maybe+import Graphics.PS hiding (a0, a1)+import Graphics.PS.Path.Graphs+import System.Directory+import System.Environment+import System.FilePath.Posix+import System.Random++-- | Group a list into a list of /n/ element lists.+clump :: Int -> [a] -> [[a]]+clump n l =+    case l of+      [] -> []+      _ -> let (i,j) = splitAt n l+           in i : clump n j++-- | Given seed /s/ 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++-- | Grey fill operator.+gfill :: Double -> Path -> Image+gfill g = Fill (greyGS g)++-- | Grey stroke operator.+gstroke :: Double -> Path -> Image+gstroke g = Stroke (greyGS g)++-- | Thin grey stroke operator.+gstroke' :: Double -> Path -> Image+gstroke' g = Stroke (GS (RGB g g g) 0.01 RoundCap RoundJoin ([],0) 10.0)++-- | Bold blue stroke operator.+bstroke :: Path -> Image+bstroke = Stroke (GS (RGB 0.0 0.0 1.0) 16.0 RoundCap RoundJoin ([],0) 10.0)++-- | Crappy normalizer, ought to do bounds checks and take paper size.+normalize :: Path -> Path+normalize p =+    let s = 250+        z = 250+    in (translate s s . scale z z) p++-- | 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 =+    let t = Text (Font "Times" 72) "SimpleText"+    in gstroke 0.25 (MoveTo (Pt 100 400) +++ t)++rectangle_ :: [Double] -> Image+rectangle_ [g,x,y,z] =+    let x' = x * 500+        y' = y * 500+        z' = z * 64+        shift = translate x' y' . scale z' z'+    in gfill g (shift (rectangle origin 1 1))+rectangle_ _ = error "illegal rectangle_"++-- | A random scattering of filled grey rectangles.+rectangles :: Image+rectangles = (foldl1 over . map rectangle_ . clump 4) (randn 1 240 0 1)++-- Angles in Hps are in radians and counter-clockwise.++-- A Path must begin with a MoveTo operator.++-- | 'arc' makes a path composed of bezier curves.+semiarc :: [Double] -> Image+semiarc [g,x,y,z] =+    let x' = x * 500+        y' = y * 500+        z' = z * 64+        shift = translate x' y' . scale z' z'+    in (gstroke' g . shift . mkValid) (arc origin 1 0 (1.5 * pi))+semiarc _ = error "illegal semiarc"++-- | A random scattering of stroked arcs.+semiarcs :: Image+semiarcs = (foldl1 over . map semiarc . clump 4) (randn 1 120 0 1)++-- | '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] =+    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 f g $ shift $ mkValid $ annular origin ir' xr' sa' a'+semiann _ _ = error "illegal semiann"++-- | A random set of annular sections.+semiannsS :: Image+semiannsS = foldl1 over $ map (semiann gstroke') $ clump 5 $ randn 1 50 0 1++semiannsF :: Image+semiannsF = foldl1 over $ map (semiann gfill) $ clump 5 $ randn 1 50 0 1++-- |flatten| applies all tranformations on a path generating a new+-- path.++curve_ex :: Image+curve_ex =+    let 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+    in s 0 c `over` s 0.5 l++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 =+    let 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+    in s 0 e0 `over` f 0.9 e1 `over` s 0.5 e2++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)++hps :: [Image]+hps =+    let arrows = fractalArrow 200 9+        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 = let e = close path_ex'+                in s 0 e `over` f 0.9 e+        s n = gstroke' n . normalize+        f n = gfill n . normalize+    in [ gstroke 0 fractal_sqr+       , gstroke 0 fractal_sqr'+       , 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+       ]++heps :: Image+heps = bstroke (erat (Pt 48 32) 120)++bb :: BBox+bb = HRBBox 35 19 180 164 40.0 24.0 176.0 160.0++writing :: String -> IO ()+writing fn = print ("writing output to: " ++ fn)++-- | Usage: main [ps_file_path] [eps_file_path]+--   Defaults are used for unsupplied args+main :: IO ()+main = do+  a <- getArgs+  u <- getUserDocumentsDirectory+  let ofn = case a of+              x:_ -> x+              _ -> u </> "hps.ps"+      epsfn = case a of+                [_,x] -> x+                _ -> u </> "heps.eps"+  writing ofn+  ps ofn a4 hps+  writing epsfn+  eps epsfn bb heps

@@ -2,5 +2,7 @@  partial and trivial postcript rendering -(c) rohan drape 2006-2010+(c) rohan drape and others, 2006-2011     gpl.2, http://gnu.org/copyleft/+    with contributions by declan murphy & henning thielemann+    see darcs history for details

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain

@@ -1,3 +0,0 @@-#!/usr/bin/env runhaskell-> import Distribution.Simple-> main = defaultMain

@@ -1,24 +1,20 @@ Name:              hps-Version:           0.2+Version:           0.11 Synopsis:          Haskell Postscript Description:       Haskell library partially implementing the                    postscript drawing model. License:           GPL Category:          Graphics-Copyright:         Rohan Drape, 2006-2010-Author:            Rohan Drape+Copyright:         Rohan Drape, 2006-2011+Author:            Rohan Drape and others Maintainer:        rd@slavepianos.org Stability:         Experimental Homepage:          http://slavepianos.org/rd/?t=hps-Tested-With:       GHC == 6.10.3+Tested-With:       GHC == 7.2.2 Build-Type:	   Simple-Cabal-Version:     >= 1.6+Cabal-Version:     >= 1.8  Data-files:        README-                   Help/Animation.hs-                   Help/Fractal.hs-                   Help/HaskellPostScript.hs-                   Help/Screen.hs  Library   Build-Depends:   base == 4.*@@ -28,6 +24,7 @@                    Graphics.PS.Matrix                    Graphics.PS.Bezier                    Graphics.PS.Path+                   Graphics.PS.Path.Graphs                    Graphics.PS.Glyph                    Graphics.PS.Font                    Graphics.PS.Image@@ -38,6 +35,16 @@                    Graphics.PS.Paper                    Graphics.PS.PS                    Graphics.PS.Unit++Executable hps-fractals+  hs-source-dirs:  . Help+  Build-Depends:   base == 4.*,+                   directory,+                   filepath,+                   random+  Main-Is:         fractals.hs+  Ghc-Options:     -Wall -fwarn-tabs+  Other-Modules:   Graphics.PS  Source-Repository  head   Type:            darcs