hps-0.11: Help/fractals.hs

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