hps-0.1: Help/HaskellPostScript.hs

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 ]