hps 0.11 → 0.16
raw patch · 21 files changed
Files
- Graphics/PS.hs +4/−6
- Graphics/PS/Bezier.hs +0/−25
- Graphics/PS/Font.hs +1/−1
- Graphics/PS/GS.hs +10/−10
- Graphics/PS/Glyph.hs +1/−1
- Graphics/PS/Image.hs +26/−3
- Graphics/PS/Matrix.hs +0/−90
- Graphics/PS/PS.hs +172/−173
- Graphics/PS/Paper.hs +61/−80
- Graphics/PS/Paper/Names.hs +94/−0
- Graphics/PS/Path.hs +90/−73
- Graphics/PS/Path/Graphs.hs +7/−7
- Graphics/PS/Pt.hs +0/−80
- Graphics/PS/Query.hs +38/−24
- Graphics/PS/Statistics.hs +16/−9
- Graphics/PS/Transform.hs +16/−16
- Graphics/PS/Unit.hs +16/−8
- Graphics/PS/Util.hs +19/−0
- Help/fractals.hs +0/−204
- README +14/−6
- hps.cabal +11/−19
Graphics/PS.hs view
@@ -1,7 +1,5 @@ -- | Top-level module for @hps@.-module Graphics.PS (module Graphics.PS.Pt,- module Graphics.PS.Bezier,- module Graphics.PS.Path,+module Graphics.PS (module Graphics.PS.Path, module Graphics.PS.Glyph, module Graphics.PS.Font, module Graphics.PS.Image,@@ -11,10 +9,10 @@ module Graphics.PS.Paper, module Graphics.PS.Query, module Graphics.PS.PS,- module Graphics.PS.Unit) where+ module Graphics.PS.Unit,+ module Data.CG.Minus) where -import Graphics.PS.Pt-import Graphics.PS.Bezier+import Data.CG.Minus import Graphics.PS.Path import Graphics.PS.Glyph import Graphics.PS.Font
− Graphics/PS/Bezier.hs
@@ -1,25 +0,0 @@--- | Bezier functions.-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---}---- | 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 =- 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
@@ -1,5 +1,5 @@ -- | Font type and functions.-module Graphics.PS.Font (Font(..)) where+module Graphics.PS.Font where -- | Font data type. data Font = Font {fontName :: String
Graphics/PS/GS.hs view
@@ -1,10 +1,5 @@ -- | PS graphics state.-module Graphics.PS.GS (GS(..)- ,LineCap(..)- ,LineJoin(..)- ,LineWidth- ,Color(..)- ,defaultGS, greyGS) where+module Graphics.PS.GS where -- | Line cap enumeration. data LineCap = ButtCap@@ -21,12 +16,17 @@ | BevelJoin deriving (Eq, Show, Enum) --- | Colour model.-data Color = RGB Double Double Double+-- | Colour model. Postscript doesn't support alpha, but store it for PDF rendering etc.+data Color = RGBA Double Double Double Double deriving (Eq, Show) -- | Graphics state.-data GS = GS Color LineWidth LineCap LineJoin ([Int], Int) Double+data GS = GS {gs_color :: Color+ ,gs_line_width :: LineWidth+ ,gs_line_cap :: LineCap+ ,gs_line_join :: LineJoin+ ,gs_dash :: ([Int], Int)+ ,gs_miter_limit :: Double} deriving (Eq, Show) -- | Default 'GS' of indicated 'Color'.@@ -35,7 +35,7 @@ -- | Default 'GS' of indicated shade of grey. greyGS :: Double -> GS-greyGS g = defaultGS (RGB g g g)+greyGS g = defaultGS (RGBA g g g 1) {-- blackGS :: GS
Graphics/PS/Glyph.hs view
@@ -1,5 +1,5 @@ -- | Glyph data type.-module Graphics.PS.Glyph (Glyph) where+module Graphics.PS.Glyph where -- | Character data type. type Glyph = Char
Graphics/PS/Image.hs view
@@ -1,21 +1,44 @@ -- | Image type and functions.-module Graphics.PS.Image (Image(..),over) where+module Graphics.PS.Image where -import Graphics.PS.Matrix+import Data.Monoid (Monoid, mappend, mconcat, mempty) {- base (obsolete) -}++import Data.CG.Minus.Types {- hcg-minus -}+ import Graphics.PS.Path import Graphics.PS.GS -- | An image is a rendering of a graph of 'Path's. data Image = Stroke GS Path | Fill GS Path- | ITransform Matrix Image+ | ITransform (Matrix Double) Image | Over Image Image | Empty deriving (Eq, Show) +instance Monoid Image where+ mempty = Empty+ mappend = Over+ mconcat = foldr Over Empty+ -- | Layer one 'Image' over another. over :: Image -> Image -> Image over = Over++-- | List of 'Path's at 'Image'.+paths :: Image -> [Path]+paths =+ let rec m i =+ let f = maybe id PTransform m+ in case i of+ Stroke _ p -> [f p]+ Fill _ p -> [f p]+ ITransform m' i' ->+ let m'' = maybe m' (* m') m+ in rec (Just m'') i'+ Over l r -> rec m l ++ rec m r+ Empty -> []+ in rec Nothing {- -- | Apply a function to leaf nodes.
− Graphics/PS/Matrix.hs
@@ -1,90 +0,0 @@--- | 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)---- | Enumeration of 'Matrix' indices.-data Matrix_Index = I0 | I1 | I2--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 :: 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 :: Matrix -> Matrix -> Matrix-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) -> 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) -> 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')--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---- | A translation matrix with independent x and y offsets.-translation :: R -> R -> Matrix-translation = Matrix 1 0 0 1---- | A scaling matrix with independent x and y scalars.-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 -> Matrix-rotation a =- let c = cos a- s = sin a- t = negate s- in Matrix c s t c 0 0---- | The identity matrix.-identity :: Matrix-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
@@ -1,19 +1,17 @@ -- | Postscript generator.-module Graphics.PS.PS (ps,eps,stringFromPS) where+module Graphics.PS.PS where -import Graphics.PS.Pt-import qualified Graphics.PS.Matrix as M+import Data.CG.Minus {- hcg-minus -}+import Data.List {- base -}+import Data.Monoid {- base -}+import System.IO {- base -}+ 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-import Data.Monoid (Monoid, mappend, mempty, mconcat, Endo(Endo,appEndo), ) - data PS = Name String | LName String | Op String@@ -21,56 +19,62 @@ | Int Int | Double Double | String String- | Matrix M.Matrix+ | Transform (Matrix Double) | 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))+dscPS :: String -> [String] -> PS+dscPS k v =+ case v of+ [] -> Comment ('%' : k)+ _ ->Comment (concat ("%" : k : ": " : intersperse " " v)) -header,headerEps :: PS-header = Comment "!PS-Adobe-3.0"-headerEps = Comment "!PS-Adobe-3.0 EPSF-3.0"+headerPS :: PS+headerPS = Comment "!PS-Adobe-3.0" -title :: String -> PS-title t = dsc "Title" [t]+headerEPS :: PS+headerEPS = Comment "!PS-Adobe-3.0 EPSF-3.0" -creator :: String -> PS-creator t = dsc "Creator" [t]+titlePS :: String -> PS+titlePS t = dscPS "Title" [t] -languageLevel :: Int -> PS-languageLevel n = dsc "LanguageLevel" [show n]+creatorPS :: String -> PS+creatorPS t = dscPS "Creator" [t] -pages :: Int -> PS-pages n = dsc "Pages" [show n]+languageLevelPS :: Int -> PS+languageLevelPS n = dscPS "LanguageLevel" [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']]+pagesPS :: Int -> PS+pagesPS n = dscPS "Pages" [show n] -endComments :: PS-endComments = dsc "EndComments" []+bboxPS :: P.BBox -> PS+bboxPS b =+ case b of+ P.BBox i j k l -> dscPS "BoundingBox" [show i,show j,show k,show l]+ P.HRBBox i j k l i' j' k' l' ->+ Seq [dscPS "BoundingBox" [show i,show j,show k,show l],+ dscPS "HiResBoundingBox" [show i',show j',show k',show l']] -page :: (Show a) => String -> a -> PS-page t n = dsc "Page" [t, show n]+endCommentsPS :: PS+endCommentsPS = dscPS "EndComments" [] -trailer :: PS-trailer = dsc "Trailer" []+pagePS :: (Show a) => String -> a -> PS+pagePS t n = dscPS "Page" [t, show n] -eof :: PS-eof = dsc "EOF" []+trailerPS :: PS+trailerPS = dscPS "Trailer" [] -documentMedia :: String -> Int -> Int -> PS-documentMedia tag w h = dsc "DocumentMedia" [tag, show w, show h, "0", "()", "()"]+eofPS :: PS+eofPS = dscPS "EOF" [] -alias :: String -> String -> PS-alias o a = Seq [LName a, Proc [Name o], Op "def"]+documentMediaPS :: String -> Int -> Int -> PS+documentMediaPS tag w h = dscPS "DocumentMedia" [tag, show w, show h, "0", "()", "()"] +aliasPS :: String -> String -> PS+aliasPS o a = Seq [LName a, Proc [Name o], Op "def"]+ pdfCompat :: [(String, String)] pdfCompat = [("gsave", "q"), ("grestore", "Q"),@@ -91,162 +95,157 @@ ("selectfont", "Tf"), ("clip", "W")] -prolog :: PS-prolog =- let f (a,b) = alias a b+prologPS :: PS+prologPS =+ let f (a,b) = aliasPS a b in Seq (map f pdfCompat) -stroke :: PS-stroke = Op "S"--fill :: PS-fill = Op "f"+strokePS :: PS+strokePS = Op "S" -false :: PS-false = Name "false"+fillPS :: PS+fillPS = Op "f" -save :: PS-save = Op "q"+falsePS :: PS+falsePS = Name "false" -restore :: PS-restore = Op "Q"+savePS :: PS+savePS = Op "q" -showPage :: PS-showPage = Op "showpage"+restorePS :: PS+restorePS = Op "Q" -rgb :: Color -> PS-rgb (RGB r g b) = Seq [Double r, Double g, Double b, Op "RG"]+showPagePS :: PS+showPagePS = Op "showpage" -lineWidth :: Double -> PS-lineWidth w = Seq [Double w, Op "w"]+rgbaPS :: Color -> PS+rgbaPS (RGBA r g b _) = Seq [Double r, Double g, Double b, Op "RG"] -lineCap :: (Enum a) => a -> PS-lineCap c = Seq [Int (fromEnum c), Op "j"]+lineWidthPS :: Double -> PS+lineWidthPS w = Seq [Double w, Op "w"] -lineJoin :: (Enum a) => a -> PS-lineJoin j = Seq [Int (fromEnum j), Op "J"]+lineCapPS :: (Enum a) => a -> PS+lineCapPS c = Seq [Int (fromEnum c), Op "j"] -dash :: [Int] -> Int -> PS-dash d o = Seq [Array (map Int d), Int o, Op "d"]+lineJoinPS :: (Enum a) => a -> PS+lineJoinPS j = Seq [Int (fromEnum j), Op "J"] -miterLimit :: Double -> PS-miterLimit m = Seq [Double m, Op "M"]+dashPS :: [Int] -> Int -> PS+dashPS d o = Seq [Array (map Int d), Int o, Op "d"] -moveTo :: Pt -> PS-moveTo (Pt x y) = Seq [Double x, Double y, Op "m"]+miterLimitPS :: Double -> PS+miterLimitPS m = Seq [Double m, Op "M"] -lineTo :: Pt -> PS-lineTo (Pt x y) = Seq [Double x, Double y, Op "l"]+moveToPS :: Pt Double -> PS+moveToPS (Pt x y) = Seq [Double x, Double y, Op "m"] -transform :: M.Matrix -> PS-transform m = Seq [Matrix m, Op "cm"]+lineToPS :: Pt Double -> PS+lineToPS (Pt x y) = Seq [Double x, Double y, Op "l"] -curveTo :: Pt -> Pt -> Pt -> PS-curveTo a b c = Seq (map Double (ptXYs [a,b,c]) ++ [Op "c"])+transformPS :: Matrix Double -> PS+transformPS m = Seq [Transform m, Op "cm"] -closePath :: Pt -> PS-closePath (Pt x y) = Seq [Double x, Double y, Op "h"]+curveToPS :: Pt Double -> Pt Double -> Pt Double -> PS+curveToPS a b c = Seq (map Double (ls_xy (Ls [a,b,c])) ++ [Op "c"]) -selectFont :: Font -> PS-selectFont (Font f n) = Seq [LName f, Double n, Op "Tf"]+closePathPS :: Pt Double -> PS+closePathPS (Pt x y) = Seq [Double x, Double y, Op "h"] -charPath :: String -> PS-charPath g = Seq [String g, false, Op "charpath"]+selectFontPS :: Font -> PS+selectFontPS (Font f n) = Seq [LName f, Double n, Op "Tf"] -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]+charPathPS :: String -> PS+charPathPS g = Seq [String g, falsePS, Op "charpath"] -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 (ClosePath p) = closePath p-path (PTransform m p) = Seq [transform m, path p]-path (Join a b) = Seq [path a, path b]+gsPS :: GS -> PS+gsPS (GS c w k j (d, o) m) =+ Seq [rgbaPS c+ ,lineWidthPS w+ ,lineCapPS k+ ,lineJoinPS j+ ,dashPS d o+ ,miterLimitPS m] -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 [transform m, image i]-image (I.Over a b) = Seq [save- ,image b- ,restore- ,image a]+pathPS :: Path -> PS+pathPS path =+ case path of+ MoveTo p -> moveToPS p+ LineTo p -> lineToPS p+ Text f g -> Seq [selectFontPS f, charPathPS g]+ CurveTo c1 c2 p -> curveToPS c1 c2 p+ ClosePath p -> closePathPS p+ PTransform m p -> Seq [transformPS m, pathPS p]+ Join a b -> Seq [pathPS a, pathPS b] -mlist :: M.Matrix -> [Double]-mlist (M.Matrix a b c d e f) = [a,b,c,d,e,f]+imagePS :: I.Image -> PS+imagePS img =+ case img of+ I.Empty -> Comment "Empty"+ I.Stroke g p -> Seq [pathPS p, gsPS g, strokePS]+ I.Fill g p -> Seq [pathPS p, gsPS g, fillPS]+ I.ITransform m i -> Seq [transformPS m, imagePS i]+ I.Over a b -> Seq [savePS+ ,imagePS b+ ,restorePS+ ,imagePS a] 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 =+ps_bracket :: (Monoid m) => (String -> m) -> String -> String -> [a] -> (a -> m) -> m+ps_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 :: (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) = mconcat (map (put f) a)+ps_escape :: String -> String+ps_escape = concatMap (\c -> if elem c "()" then ['\\', c] else [c]) -ps' :: (I.Image, Int) -> PS-ps' (p, n) = Seq [page "Graphics.PS" n, image p, showPage]+ps_put :: (Monoid m) => (String -> m) -> PS -> m+ps_put f x =+ case x of+ Name n -> f n >+> f " "+ LName n -> f "/" >+> f n >+> f " "+ Op o -> f o >+> f "\n"+ Comment o -> f "%" >+> f o >+> f "\n"+ Int n -> f (show n) >+> f " "+ Double n -> f (show n) >+> f " "+ String s -> f "(" >+> f (ps_escape s) >+> f ") "+ Array a -> ps_bracket f "[" "]" a (ps_put f)+ Proc p -> ps_bracket f "{" "}" p (ps_put f)+ Transform m -> ps_put f (Array (map Double (mx_list m)))+ Dict d -> let g = concatMap (\(a,b) -> [a,b]) in ps_bracket f "<<" ">>" (g d) (ps_put f)+ Seq a -> mconcat (map (ps_put f) a) -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)+to_page_seq :: (I.Image, Int) -> PS+to_page_seq (p, n) = Seq [pagePS "Graphics.PS" n, imagePS p, showPagePS] --- | Write a postscript file. The list of images are written--- one per page.+-- | Write a postscript file. The list of images are written one per page. ps :: FilePath -> P.Paper -> [I.Image] -> IO ()-ps f d p =- writeFile f (stringFromPS f d p)+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- 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+-- | Variant with page (paper) size in points.+stringFromPS_pt :: String -> (Int,Int) -> [I.Image] -> String+stringFromPS_pt t (width,height) p =+ let g = ps_put (\s -> Endo (s++))+ in flip appEndo "" $+ g headerPS >+>+ g (titlePS t) >+>+ g (creatorPS "Graphics.PS") >+>+ g (languageLevelPS 2) >+>+ g (pagesPS (length p)) >+>+ g (documentMediaPS "Default" width height) >+>+ g endCommentsPS >+>+ g prologPS >+>+ mconcat (map (g . to_page_seq) (zip p [1..])) >+>+ g trailerPS >+>+ g eofPS +-- | Generate postscript data given /title/, page size, and a+-- set of page 'I.Images'.+stringFromPS :: String -> P.Paper -> [I.Image] -> String+stringFromPS t p = stringFromPS_pt t (P.paper_size_pt p) newtype MonadMonoid m = MonadMonoid {appMonadMonoid :: m ()} @@ -256,21 +255,21 @@ 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]+-- | Write an encapsulated postscript file. The 'P.BBox' is in+-- points. The single image is written.+eps :: FilePath -> P.BBox -> I.Image -> IO ()+eps fn d p =+ withFile fn WriteMode $ \h ->+ let g = ps_put (MonadMonoid . hPutStr h)+ in mapM_ (appMonadMonoid . g) $+ [headerEPS+ ,titlePS ("Graphics.PS: " ++ fn)+ ,creatorPS "Graphics.PS"+ ,languageLevelPS 2+ ,bboxPS d+ ,endCommentsPS+ ,prologPS+ ,imagePS p] {--
Graphics/PS/Paper.hs view
@@ -1,12 +1,28 @@--- | Paper sizes.--- For ISO sizes see <http://www.cl.cam.ac.uk/~mgk25/iso-paper.html>.+-- | Paper and BBox. module Graphics.PS.Paper where --- | Paper size data type.-data Paper = Paper {width :: Int+import Graphics.PS.Unit++-- | Enumeration type for Units.+data Units = MM | PT deriving (Eq,Show)++-- | Paper size data type, the units are specified in the type.+-- The units in postscript are points, we often work in millimeters.+data Paper = Paper {units :: Units+ ,width :: Int ,height :: Int} deriving (Eq,Show) +-- | Translate 'Paper' from mm to points.+--+-- > let a4 = Paper MM 210 297+-- > paper_size_pt a4 == (595,841)+paper_size_pt :: Paper -> (Int,Int)+paper_size_pt (Paper unit w h) =+ case unit of+ MM -> (mm_pt_int w,mm_pt_int h)+ PT -> (w,h)+ -- | 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)@@ -26,89 +42,54 @@ -- | Swap width and height of 'Paper'. landscape :: Paper -> Paper-landscape (Paper w h) = Paper h w+landscape (Paper u w h) = Paper u h w --- | A 'div' variant that rounds rather than truncates.+-- | Proportion of 'Paper'. ----- > 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 =- let x' = (fromIntegral x)::Double- y' = (fromIntegral y)::Double- in round (x' / y')+-- > import Graphics.PS.Paper.Names+-- > proportion broadsheet == 1.25+-- > map (round . (* 1e3) . proportion) [a0,b0,c0] == [1414,1414,1414]+-- > map proportion [usLetter,berliner,tabloid]+proportion :: Paper -> Double+proportion (Paper _ w h) = i_to_d h / i_to_d w --- | 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+-- | The margin given by placing paper size /p/ within /q/.+inset_margin :: Paper -> Paper -> (Units,Int,Int)+inset_margin (Paper u1 w1 h1) (Paper u2 w2 h2) =+ if u1 /= u2+ then error "inset_margin: unequal units"+ else (u2,(w2 - w1) `div` 2,(h2 - h1) `div` 2) --- | ISO A sizes in millimeters.------ > 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-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+-- * BBox --- | ISO B sizes in millimeters.+-- | Sum of 'BBox'. ----- > 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-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+-- > bbox_sum (BBox 5 5 10 10) (BBox 0 0 2 20) == BBox 0 0 10 20+bbox_sum :: BBox -> BBox -> BBox+bbox_sum p q =+ case (p,q) of+ (BBox x0 y0 x1 y1,BBox x2 y2 x3 y3) ->+ BBox (min x0 x2) (min y0 y2) (max x1 x3) (max y1 y3)+ _ -> error "bbox_sum: HR not handled" --- | ISO C sizes in millimeters.------ > 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-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+-- | Translate 'BBox' from mm to points.+bbox_mm_to_pt :: BBox -> BBox+bbox_mm_to_pt bb =+ case bb of+ BBox x y x' y' ->+ BBox (mm_pt_int x) (mm_pt_int y) (mm_pt_int x') (mm_pt_int y')+ HRBBox x y x' y' hx hy hx' hy' ->+ HRBBox (mm_pt_int x) (mm_pt_int y) (mm_pt_int x') (mm_pt_int y')+ (mm_pt hx) (mm_pt hy) (mm_pt hx') (mm_pt hy') --- | US Letter size in millimeters (ie 'Paper' @216 279@).-usLetter :: Paper-usLetter = Paper 216 279+{- | A 'div' variant that rounds rather than truncates. --- | 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+> 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 --- | 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)+-}+divRound :: Int -> Int -> Int+divRound x y =+ let x' = (fromIntegral x)::Double+ y' = (fromIntegral y)::Double+ in round (x' / y')
+ Graphics/PS/Paper/Names.hs view
@@ -0,0 +1,94 @@+-- | Names of paper sizes.+-- For ISO sizes see <http://www.cl.cam.ac.uk/~mgk25/iso-paper.html>.+module Graphics.PS.Paper.Names where++import Graphics.PS.Paper++-- | ISO size downscaling, ie. from @A0@ to @A1@.+--+-- > iso_down_scale a4 == a5+iso_down_scale :: Paper -> Paper+iso_down_scale (Paper u w h) = Paper u (h `divRound` 2) w++-- | JIS size downscaling, truncates instead of rounding.+jis_down_scale :: Paper -> Paper+jis_down_scale (Paper u w h) = Paper u (h `div` 2) w++-- | ISO A sizes in millimeters.+--+-- > a4 == Paper 210 297+a0,a1,a2,a3,a4,a5,a6,a7,a8,a9,a10 :: Paper+a0 = Paper MM 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.+--+-- > b4 == Paper 250 354+-- > inset_margin b4 a3 == (23,33)+b0,b1,b2,b3,b4,b5,b6,b7,b8,b9,b10 :: Paper+b0 = Paper MM 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++-- | JIS B sizes+--+-- > jis_b4 == Paper 257 364+-- > (proportion b0,proportion jis_b0) == (1.414,1.4135922330097088)+--+-- > inset_margin jis_b4 a3 == (20,28)+jis_b0,jis_b1,jis_b2,jis_b3,jis_b4,jis_b5,jis_b6,jis_b7,jis_b8,jis_b9,jis_b10 :: Paper+jis_b0 = Paper MM 1030 1456+jis_b1 = jis_down_scale jis_b0+jis_b2 = jis_down_scale jis_b1+jis_b3 = jis_down_scale jis_b2+jis_b4 = jis_down_scale jis_b3+jis_b5 = jis_down_scale jis_b4+jis_b6 = jis_down_scale jis_b5+jis_b7 = jis_down_scale jis_b6+jis_b8 = jis_down_scale jis_b7+jis_b9 = jis_down_scale jis_b8+jis_b10 = jis_down_scale jis_b9++-- | ISO C sizes in millimeters.+--+-- > c4 == Paper 229 324+c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10 :: Paper+c0 = Paper MM 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 (ie 'Paper' @216 279@).+usLetter :: Paper+usLetter = Paper MM 216 279++-- | Newspaper sizes in millimeters.+-- See <http://www.papersizes.org/newspaper-sizes.htm>.+broadsheet,berliner,tabloid :: Paper+broadsheet = Paper MM 600 750+berliner = Paper MM 315 470+tabloid = Paper MM 280 430
Graphics/PS/Path.hs view
@@ -1,26 +1,30 @@ -- | Path type and functions.-module Graphics.PS.Path (Path(..),(+++)- ,line,polygon,rectangle- ,arc,arcNegative,annular- ,flatten- ,renderLines,renderLines') where+module Graphics.PS.Path where -import Data.List-import Graphics.PS.Pt-import Graphics.PS.Matrix+import Data.List {- base -}+import Data.Monoid (Monoid, mappend, mconcat, mempty) {- base (obsolete) -}++import Data.CG.Minus {- hcg-minus -}+ import Graphics.PS.Glyph import Graphics.PS.Font -- | Path data type,in cartesian space.-data Path = MoveTo Pt- | LineTo Pt- | CurveTo Pt Pt Pt- | ClosePath Pt+data Path = MoveTo (Pt Double)+ | LineTo (Pt Double)+ | CurveTo (Pt Double) (Pt Double) (Pt Double)+ | ClosePath (Pt Double) | Text Font [Glyph]- | PTransform Matrix Path+ | PTransform (Matrix Double) Path | Join Path Path deriving (Eq,Show) +instance Monoid Path where+ mempty = MoveTo (Pt 0 0)+ mappend = Join+ mconcat [] = mempty+ mconcat paths = combine paths+ -- | Infix notation for 'Join'. (+++) :: Path -> Path -> Path (+++) = Join@@ -30,22 +34,22 @@ combine = foldl1 Join -- | Line segments though list of 'Pt'.-line :: [Pt] -> Path+line :: [Pt Double] -> Path line x = case x of [] -> error "line: illegal data" (p:ps) -> combine (MoveTo p : map LineTo ps) -- | Variant of 'line' connecting the last 'Pt' to the first.-polygon :: [Pt] -> Path+polygon :: [Pt Double] -> Path polygon x = case x of [] -> error "polygon: illegal data" (p:ps) -> line (p:ps) +++ ClosePath p -- | Rectangle with lower left at 'Pt' and of specified width and--- height. Polygon is oredered anticlockwise from lower left.-rectangle :: Pt -> Double -> Double -> Path+-- height. Polygon is ordered anticlockwise from lower left.+rectangle :: Pt Double -> Double -> Double -> Path rectangle (Pt x y) w h = let ll = Pt x y lr = Pt (x + w) y@@ -53,12 +57,15 @@ ul = Pt x (y + h) in polygon [ll,lr,ur,ul] -type ArcP = (Pt,Pt,Pt,Pt)-data Arc = Arc1 ArcP- | Arc2 ArcP ArcP+-- | An arc segment, as starting point and values for the curveto operator.+type Arc_Seg n = (Pt n,Pt n,Pt n,Pt n) --- (x,y) = center,r = radius,a = start angle,b = end angle-arcp :: Pt -> Double -> Double -> Double -> ArcP+-- | An arc, given as either one or two segments.+data Arc n = Arc1 (Arc_Seg n)+ | Arc2 (Arc_Seg n) (Arc_Seg n)++-- | Arc segment, (x,y) = center,r = radius,a = start angle,b = end angle.+arcp :: Pt Double -> Double -> Double -> Double -> Arc_Seg Double arcp (Pt x y) r a b = let ca = cos a sa = sin a@@ -71,9 +78,10 @@ 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+-- | Arc, 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 segments.+arca :: Pt Double -> Double -> Double -> Double -> Arc Double arca c r a b = let d = abs (b - a) b' = b - (d / 2)@@ -81,36 +89,39 @@ 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 +++ 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 +++ c1 +++ c2+-- | 'Path' of 'Arc'.+arc_to_path :: Arc Double -> Path+arc_to_path a =+ case a of+ Arc1 (p0,p1,p2,p3) -> MoveTo p0 +++ CurveTo p1 p2 p3+ Arc2 (p0,p1,p2,p3) (_,p5,p6,p7) -> MoveTo p0 +++ CurveTo p1 p2 p3 +++ CurveTo p5 p6 p7 +-- | Variant of 'arca' allowing b to be less than a.+arca_udir :: Pt Double -> Double -> Double -> Double -> Arc Double+arca_udir c r a b =+ let b' = if b < a then b + 2 * pi else b+ in arca c r a b'++-- | 'arca_udir' with a and b reversed.+arcNegative_udir :: Pt Double -> Double -> Double -> Double -> Arc Double+arcNegative_udir c r a b =+ let b' = if b > a then b - 2 * pi else b+ in arca c r b' a+ -- | 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))+arc :: Pt Double -> Double -> Double -> Double -> Path+arc c r a = arc_to_path . arca_udir c r a -- | 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)+arcNegative :: Pt Double -> Double -> Double -> Double -> Path+arcNegative c r a = arc_to_path . arcNegative_udir c r a --- (x,y) = center,ir = inner radius,xr = outer radius,sa = start--- angle,a = angle,ea = end angle+type Annular n = (Pt n,Pt n,Arc n,Pt n,Arc n) --- | Annular segment.-annular :: Pt -> Double -> Double -> Double -> Double -> Path-annular (Pt x y) ir xr sa a =+-- | (x,y) = center,ir = inner radius,xr = outer radius,sa = start+-- angle,a = angle,ea = end angle+annular_f :: Pt Double -> Double -> Double -> Double -> Double -> Annular Double+annular_f (Pt x y) ir xr sa a = let ea = sa + a x2 = x + ir * cos sa -- ll y2 = y + ir * sin sa@@ -118,45 +129,51 @@ 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]+ in (Pt x2 y2+ ,Pt x3 y3+ ,arca_udir (Pt x y) xr sa ea+ ,Pt x4 y4+ ,arcNegative_udir (Pt x y) ir ea sa) -flatten' :: Matrix -> Path -> Path-flatten' m path =+-- | Annular segment.+annular :: Pt Double -> Double -> Double -> Double -> Double -> Path+annular c ir xr sa a =+ let (p1,p2,a1,p3,a2) = annular_f c ir xr sa a+ in combine [MoveTo p1,LineTo p2,arc_to_path a1,LineTo p3,arc_to_path a2]++flatten_f :: Matrix Double -> Path -> Path+flatten_f 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+ MoveTo p -> MoveTo (pt_transform m p)+ LineTo p -> LineTo (pt_transform m p)+ ClosePath p -> ClosePath (pt_transform m p)+ PTransform m' p -> flatten_f (m' * m) p+ Join a b -> Join (flatten_f m a) (flatten_f m b)+ CurveTo p q r -> let f = pt_transform 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 'PTransform' nodes. flatten :: Path -> Path-flatten = flatten' identity+flatten = flatten_f mx_identity -- | Render each (p1,p2) as a distinct line.-renderLines :: [(Pt,Pt)] -> Path+renderLines :: [Ln Double] -> Path renderLines =- let f pth (p1,p2) = pth +++ MoveTo p1 +++ LineTo p2- in foldl f (MoveTo origin)+ let f pth (Ln p1 p2) = pth +++ MoveTo p1 +++ LineTo p2+ in foldl f (MoveTo pt_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))+renderLines_jn :: [Ln Double] -> Path+renderLines_jn =+ let g p (Ln a b) = if p == a+ then (b,Right b)+ else (b,Left (Ln a b)) f path e = case e of- Left (p1,p2) -> path +++ MoveTo p1 +++ LineTo p2+ Left (Ln p1 p2) -> path +++ MoveTo p1 +++ LineTo p2 Right p2 -> path +++ LineTo p2- in foldl f (MoveTo origin) . snd . mapAccumL g origin+ in foldl f (MoveTo pt_origin) . snd . mapAccumL g pt_origin {--
Graphics/PS/Path/Graphs.hs view
@@ -1,16 +1,16 @@ -- | Set of predefined 'Path's. module Graphics.PS.Path.Graphs where +import Data.CG.Minus {- hcg-minus -} 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 :: Pt Double -> Pt Double -> Int -> [Ln Double] fractal_sqr_pt p1 p2 d = case d of- 0 -> [(p1,p2)]+ 0 -> [Ln p1 p2] _ -> let (Pt x1 y1) = p1 (Pt x2 y2) = p2 x3 = ((x1 + x2) / 2) + ((y2 - y1) / 2)@@ -22,9 +22,9 @@ fractal_sqr :: Path fractal_sqr = renderLines (fractal_sqr_pt (Pt 250 250) (Pt 175 175) 12) --- | 'renderLines'' variant of 'fractal_sqr'.+-- | 'renderLines_jn' variant of 'fractal_sqr'. fractal_sqr' :: Path-fractal_sqr' = renderLines' (fractal_sqr_pt (Pt 250 250) (Pt 175 175) 12)+fractal_sqr' = renderLines_jn (fractal_sqr_pt (Pt 250 250) (Pt 175 175) 12) -- | A /unit/ arrow. unitArrow :: Int -> Path@@ -48,11 +48,11 @@ in (translate x y . scale h h) a -- | Isosceles right angled triangle-erat :: Pt -> Double -> Path+erat :: Pt Double -> 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 :: Pt Double -> Double -> Double -> Path sierpinski p n limit = let m = n / 2 (Pt x y) = p
− Graphics/PS/Pt.hs
@@ -1,80 +0,0 @@--- | Point type and associated functions.-module Graphics.PS.Pt (Pt(Pt)- ,polarToRectangular- ,ptMin, ptMax, ptXYs, origin- ,ptTransform) where--import Graphics.PS.Matrix---- | 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)- 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, ie. (Pt 0 0).-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--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---- | Convert from polar to rectangular co-ordinates.-polarToRectangular :: Pt -> Pt-polarToRectangular (Pt r t) = Pt (r * cos t) (r * sin t)---- | Apply a transformation matrix to a point.-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
@@ -1,24 +1,23 @@ -- | 'Path' query functions and related operations.-module Graphics.PS.Query (startPt, endPt- ,mkValid- ,approx, close) where+module Graphics.PS.Query where -import Graphics.PS.Pt-import Graphics.PS.Bezier+import Data.CG.Minus.Types {- hcg-minus -}+import qualified Data.CG.Minus as CG {- hcg-minus -}+import qualified Data.CG.Minus.Bezier as CG {- hcg-minus -}++import Graphics.PS.Paper import Graphics.PS.Path --- | Locate the starting point of the path, which must begin with a--- 'MoveTo' node.-startPt :: Path -> Maybe Pt+-- | Locate the starting point of the path, which must begin with a 'MoveTo' node.+startPt :: Path -> Maybe (Pt Double) 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+-- | Variant that allows the initial node to be a 'LineTo' or 'CurveTo' node.+startPt' :: Path -> Maybe (Pt Double) startPt' path = case path of MoveTo p -> Just p@@ -35,7 +34,7 @@ Nothing -> path -- | Locate the end point of the path.-endPt :: Path -> Maybe Pt+endPt :: Path -> Maybe (Pt Double) endPt path = case path of MoveTo p -> Just p@@ -60,26 +59,41 @@ 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+ Just p1 -> map (CG.bezier4 p1 p2 p3 p4) is Nothing -> [] in a +++ line l _ -> path -{--+-- | Rectangle, given as lower left and upper right points.+data Rect a = Rect {rect_ll :: Pt a+ ,rect_ur :: Pt a}+ deriving (Eq,Show) -data BBox = BBox Pt Pt- deriving (Eq, Show)+-- | Sum (join) of two 'Rect'.+rect_sum :: Ord a => Rect a -> Rect a -> Rect a+rect_sum (Rect a b) (Rect c d) = Rect (CG.pt_min a c) (CG.pt_max b d) -import Graphics.PS.Transform+-- | Rectangle bounding a (simple) 'Path'.+path_rect :: Path -> Rect Double+path_rect path =+ case path of+ MoveTo p -> Rect p p+ LineTo p -> Rect p p+ CurveTo c0 c1 p0 -> Rect (foldl1 CG.pt_min [c0,c1,p0]) (foldl1 CG.pt_max [c0,c1,p0])+ Join p q -> path_rect p `rect_sum` path_rect q+ _ -> error "path_rect: illegal query" -bboxSum :: BBox -> BBox -> BBox-bboxSum (BBox a b) (BBox c d) = BBox (ptMin a c) (ptMax b d)+-- | Translate 'Rect' to 'BBox'.+rect_to_bbox :: RealFrac a => Rect a -> BBox+rect_to_bbox (Rect (Pt x0 y0) (Pt x1 y1)) = BBox (floor x0) (floor y0) (ceiling x1) (ceiling y1) -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"+path_to_bbox :: Path -> BBox+path_to_bbox = rect_to_bbox . path_rect++{--+++import Graphics.PS.Transform join :: Path -> Path -> Path join a b = a +++ translate x y b
Graphics/PS/Statistics.hs view
@@ -1,7 +1,9 @@ -- | 'Path' statistics.-module Graphics.PS.Statistics (Statistics(..)- ,pathStatistics) where+module Graphics.PS.Statistics where +import Data.Monoid {- base -}++import Graphics.PS.Image import Graphics.PS.Path -- | Path statistics data type.@@ -11,12 +13,14 @@ ,nClosePath :: Integer ,nGlyph :: Integer ,nTransform :: Integer}+ deriving (Eq,Show) -plus :: Statistics -> Statistics -> Statistics-plus p q =- 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)+instance Monoid Statistics where+ mempty = Statistics 0 0 0 0 0 0+ mappend p q =+ 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@@ -27,6 +31,9 @@ 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+ PTransform _ p -> Statistics 0 0 0 0 0 1 <> pathStatistics p+ Join p1 p2 -> pathStatistics p1 <> pathStatistics p2 +-- | Statistics for all 'paths' at 'Image'.+imageStatistics :: Image -> Statistics+imageStatistics = mconcat . map pathStatistics . paths
Graphics/PS/Transform.hs view
@@ -1,36 +1,36 @@+{-# Language FlexibleInstances #-} -- | Class and associated functions for 'Matrix' transformations.-module Graphics.PS.Transform (Transformable- ,translate, scale, rotate) where+module Graphics.PS.Transform where -import Graphics.PS.Matrix-import Graphics.PS.Pt+import qualified Data.CG.Minus as CG {- hcg-minus -}+ 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+class Transformable t where+ mtransform :: CG.Matrix Double -> t -> t -- | Translation in /x/ and /y/.-translate :: (Transformable a) => Double -> Double -> a -> a-translate x = transform . translation x+translate :: Transformable t => Double -> Double -> t -> t+translate x = mtransform . CG.mx_translation x -- | Scaling in /x/ and /y/.-scale :: (Transformable a) => Double -> Double -> a -> a-scale x = transform . scaling x+scale :: Transformable t => Double -> Double -> t -> t+scale x = mtransform . CG.mx_scaling x -- | Rotation, in radians.-rotate :: (Transformable a) => Double -> a -> a-rotate = transform . rotation+rotate :: Transformable t => Double -> t -> t+rotate = mtransform . CG.mx_rotation instance Transformable I.Image where- transform = I.ITransform+ mtransform = I.ITransform instance Transformable P.Path where- transform = P.PTransform+ mtransform = P.PTransform -instance Transformable Pt where- transform = ptTransform+instance Transformable (CG.Pt Double) where+ mtransform = CG.pt_transform {-- import Graphics.PS.Pt
Graphics/PS/Unit.hs view
@@ -1,17 +1,25 @@ -- | Unit definitions and conversions.-module Graphics.PS.Unit (radians, mm_pt) where+module Graphics.PS.Unit where -- | Convert degrees to radians.-radians :: (Floating a) => a -> a+radians :: Floating a => a -> a radians n = n / (360 / (2 * pi)) -- | Convert millimeters to PS points.-mm_pt :: (Floating a) => a -> a+mm_pt :: Floating a => a -> a mm_pt = (* 2.8346456664) +-- | Type specialised 'fromIntegral'.+i_to_d :: Int -> Double+i_to_d = fromIntegral++-- | 'Int' variant of 'mm_pt'.+mm_pt_int :: Int -> Int+mm_pt_int = floor . mm_pt . i_to_d+ {-- -- | Convert PS points to millimeters.-pt_mm :: (Floating a) => a -> a+pt_mm :: Floating a => a -> a pt_mm = (/ 2.8346456664) -- | Postscript makes a point exactly 1/72 of an inch.@@ -19,15 +27,15 @@ inch n = 72 * n -- | 1 cm = 0.393700787 inches-cm :: (Floating a) => a -> a+cm :: Floating a => a -> a cm n = 28.346456664 * n -twopi :: (Floating a) => a+twopi :: Floating a => a twopi = 2 * pi -halfpi :: (Floating a) => a+halfpi :: Floating a => a halfpi = pi / 2 -degrees :: (Floating a) => a -> a+degrees :: Floating a => a -> a degrees n = n * (360 / twopi) --}
+ Graphics/PS/Util.hs view
@@ -0,0 +1,19 @@+module Graphics.PS.Util where++import Control.Monad {- base -}+import System.FilePath {- filepath -}+import System.Process {- process -}++type Cmd = (String,[String])++run_cmd :: Cmd -> IO ()+run_cmd (c,a) = void (rawSystem c a)++eps_to_pdf_cmd :: FilePath -> Cmd+eps_to_pdf_cmd fn = ("ps2pdf",["-dEPSCrop",fn,replaceExtension fn ".pdf"])++-- | Run ps2pdf to translate an EPS file to a PDF file.+--+-- > eps_to_pdf "/tmp/t.0.eps"+eps_to_pdf :: FilePath -> IO ()+eps_to_pdf = run_cmd . eps_to_pdf_cmd
− Help/fractals.hs
@@ -1,204 +0,0 @@-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
README view
@@ -1,8 +1,16 @@-hps - haskell postscript+hps+--- -partial and trivial postcript rendering+[haskell](http://haskell.org) [postscript](http://adobe.com/products/postscript/) -(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+partial and trivial rendering of the post script drawing model.++© [rohan drape](http://rd.slavepianos.org/) and others,+2006-2017,+[gpl](http://gnu.org/copyleft/).+with contributions by:++- declan murphy+- henning thielemann++see the [darcs](http://darcs.net/) [history](?t=hps&q=history) for details
hps.cabal view
@@ -1,28 +1,28 @@ Name: hps-Version: 0.11+Version: 0.16 Synopsis: Haskell Postscript Description: Haskell library partially implementing the postscript drawing model. License: GPL Category: Graphics-Copyright: Rohan Drape, 2006-2011+Copyright: Rohan Drape, 2006-2017 Author: Rohan Drape and others Maintainer: rd@slavepianos.org Stability: Experimental-Homepage: http://slavepianos.org/rd/?t=hps-Tested-With: GHC == 7.2.2+Homepage: http://rd.slavepianos.org/t/hps+Tested-With: GHC == 8.0.1 Build-Type: Simple Cabal-Version: >= 1.8 Data-files: README Library- Build-Depends: base == 4.*+ Build-Depends: base == 4.*,+ hcg-minus == 0.16.*,+ filepath,+ process GHC-Options: -Wall -fwarn-tabs Exposed-modules: Graphics.PS- Graphics.PS.Pt- Graphics.PS.Matrix- Graphics.PS.Bezier Graphics.PS.Path Graphics.PS.Path.Graphs Graphics.PS.Glyph@@ -33,19 +33,11 @@ Graphics.PS.GS Graphics.PS.Query Graphics.PS.Paper+ Graphics.PS.Paper.Names 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+ Graphics.PS.Util Source-Repository head Type: darcs- Location: http://slavepianos.org/rd/sw/hps+ Location: http://rd.slavepianos.org/sw/hps