treemaker.hs

import System.Random
import Control.Monad.State

type Point = (Double, Double)

pointPlus :: Point -> Point -> Point
pointPlus (x1, y1) (x2, y2) = (x1 + x2, y1 + y2)

polarToPoint :: Double -> Double -> Point
polarToPoint angle length
    = let x = length * sin angle
          y = length * (- cos angle)
      in (x, y)

data GrowState = GrowState { stRandoms :: [Double]  -- ^ (0..1)
                           }
type Grow a = State GrowState a

data Type = BranchType | TrunkType
    deriving Eq

genFromRange :: (Double, Double) -> Grow Double
genFromRange (min, max)
    = do st <- get
         let r:randoms = stRandoms st
         put st { stRandoms = randoms }
         return $ r * (max - min) + min

genAngleMod :: Type -> Double -> Double -> (Double, Double)
genAngleMod typ min max
    | typ == BranchType = (min, max)
    | otherwise = (min * 0.5, max * 0.5)

runGrow :: Grow a -> IO a
runGrow f = do gen <- getStdGen
               let st = GrowState { stRandoms = randomRs (0, 1) gen }
               return $ evalState f st

data Branch = Branch { branchType :: Type,
                       branchBegin :: Point,
                       branchEnd :: Point,
                       branchAnchor1 :: Point,
                       branchAnchor2 :: Point,
                       branchLength :: Double,
                       branchSize :: Double,
                       branchAngle :: Double }

makeBranch :: Branch  -- ^parent
           -> Double -- ^rand
           -> Double -- ^length
           -> Double -- ^angle
           -> Branch
makeBranch parent rand length angle
    = Branch { branchType = typ,
               branchBegin = point1,
               branchEnd = point2,
               branchAnchor1 = anchor1,
               branchAnchor2 = anchor2,
               branchLength = length',
               branchSize = branchSize parent - length' / 24,
               branchAngle = angle }
    where typ | rand < length / branchLength parent - 0.5 = branchType parent
              | otherwise = BranchType
          length' | typ == TrunkType = length * 0.95
                  | otherwise = length * 0.75
          point1 = branchEnd parent
          point2 = point1 `pointPlus` (polarToPoint angle length')
          anchor1 = point1 `pointPlus` (polarToPoint (branchAngle parent) (length' * 0.4))
          anchor2 = point2 `pointPlus` (polarToPoint (angle) (-length' * 0.3))

branches :: Branch -> Grow [Branch]
branches b | branchLength b <= 50 = return []
           | otherwise = do angle1 <- (branchAngle b +) `liftM`
                                      genFromRange ( genAngleMod (branchType b) (-40 * pi / 180) (-20 * pi / 180))
                            angle2 <- (branchAngle b +) `liftM`
                                      genFromRange ( genAngleMod (branchType b) (-20 * pi / 180) (20 * pi / 180))
                            angle3 <- (branchAngle b +) `liftM`
                                      genFromRange ( genAngleMod (branchType b) (20 * pi / 180) (40 * pi / 180))
                            length' <- (branchLength b -) `liftM`
                                       genFromRange (5, 15)
                            leftrand <- (0 +) `liftM`
                                       genFromRange (0, 1)
                            middlerand <- (0 +) `liftM`
                                       genFromRange (0, 1)
                            rightrand <- (0 +) `liftM`
                                       genFromRange (0, 1)
                            let left = makeBranch b leftrand length' angle1
                                middle = makeBranch b middlerand length' angle2
                                right = makeBranch b rightrand length' angle3
                            lefts <- branches left
                            middles <- branches middle
                            rights <- branches right
                            case () of
                              _ | leftrand + middlerand + rightrand < 0.8 ->
                                    return $ [middle] ++ middles
                              _ | branchType b == BranchType ->
                                    return $ [left, right] ++ lefts ++ rights
                              _ ->  return $ [left, middle, right] ++
                                            lefts ++
                                            middles ++
                                            rights

makeTrunk origin size start
    = Branch TrunkType origin stem origin stem start size 0
    where stem = origin `pointPlus` (polarToPoint 0 start)

{-
branch :: Value -> Double -> Double -> [Value]
branch parent stop angle
    = leftBranches ++ rightBranches
    where left = makeValue (angle - 20 * pi / 180)
          leftBranches = [left] ++ (branch left stop
-}
--class Growable d where
--    drawableNodes :: d -> [Node]

branchesToSVG bs = "<?xml version='1.0' encoding='UTF-8' standalone='no'?>" ++
                  "<svg " ++
                  "xmlns:svg='http://www.w3.org/2000/svg' " ++
                  "xmlns='http://www.w3.org/2000/svg' " ++
                  "version='1.0' " ++
                  "width='210mm' " ++
                  "height='297mm' " ++
                  "id='svg2'> " ++
                  "<defs id='defs4' /> " ++
                  "<g>" ++
                  (concat $ map branchToSVGpath bs) ++
                  "</g>" ++
                  "</svg>"
    where branchToSVGpath b
              = let size = branchSize b
                    color | branchType b == BranchType = "#2D5016"
                          | otherwise = "#552200"
                    style = "fill:none;fill-rule:evenodd;stroke:" ++ color ++
                            ";stroke-width:" ++
                            (show size) ++ "px;" ++
                            "stroke-linecap:round;stroke-linejoin:miter;stroke-opacity:1"
                in "<path d='M " ++ (s $ branchBegin b) ++
                       " C " ++ (s $ branchAnchor1 b) ++
                       " " ++ (s $ branchAnchor2 b) ++
                       " " ++ (s $ branchEnd b) ++
                       "' style='" ++ style ++ "'/>"
          s (x, y) = (show $ truncate x) ++ "," ++ (show $ truncate y)



main = do let trunk = makeTrunk (520, 1000) 30 150
          branches' <- ([trunk] ++) `liftM` (runGrow $ branches trunk)
          putStrLn $ branchesToSVG branches'