LSystem with openGL

lsystem.hs

-- | some packages i needed to install to get opengl working
-- sudo apt-get install mesa-utils libglu1-mesa-dev freeglut3-dev mesa-common-dev
--                      libglew-dev libglfw3-dev libglm-dev
--                      libao-dev libmpg123-dev xlibmesa-glu-dev

import Util
import qualified Data.Text as T
import qualified Graphics.Gloss as G
import Graphics.Gloss
import Data.Traversable
import Data.Foldable
import GHC.Generics

data Language
  = V T.Text
  | C T.Text
  deriving Eq

instructions :: LSystem -> [Instruction]
instructions (LSystem { state, representation}) = concatMap representation state

data LSystem
  = LSystem
  { name :: String
  , state :: [Language]
  , rules :: (Language -> [Language])
  , grow :: Int -- length of each line
  , angle :: Float
  , representation :: (Language -> [Instruction])
  }

instance Show Language where
  show (V t) = T.unpack t
  show (C b) = T.unpack b

step :: Int -> LSystem -> LSystem
step 0 l = l
step n l@(LSystem {rules, state = s}) =
  step (abs(n - 1)) (l { state = new })
  where
    new = concatMap rules s

data Instruction
  = Forward
  | ForwardNoDraw
  | RotateLeft
  | RotateRight
  | Push
  | Pop
  | Stay
  deriving Show
createDisplay :: String -> G.Picture -> IO ()
createDisplay name pic = do
  -- print ins
  G.display (if fullScreen then G.FullScreen else windowed) G.white pic
  where
    fullScreen = True
    windowed = G.InWindow name (200, 200) (10, 10)

--- | Draw the instructions
draw :: Float -- ^ angle
  -> Float -- ^ distance
  -> [Instruction]
  -> Picture
draw angle distance = go 90 (Line [(0,0)]) (Pictures []) []
  where
    go :: Float -> Picture -> Picture -> [(Point,Float)] -> [Instruction] -> Picture
    go _ line (Pictures ps) _ [] = Pictures (line:ps)
    go theta (Line path) (Pictures ps) stack (x:xs) =
      case x of
        Forward -> go theta (Line (p:path)) (Pictures ps) stack xs
        ForwardNoDraw -> go theta (Line [p]) (Pictures (Line path : ps)) stack xs
        RotateRight -> go (theta + angle) (Line path) (Pictures ps) stack xs
        RotateLeft -> go (theta - angle) (Line path) (Pictures ps) stack xs
        Push -> go theta (Line path) (Pictures ps) ((head path, theta):stack) xs
        Pop -> let (pos, theta'):t = stack in
          go theta' (Line [pos]) (Pictures (Line path : ps)) t xs
        Stay -> go theta (Line path) (Pictures ps) stack xs
      where
        (px, py) = head path
        thetaRad = theta * pi / 180
        p = (px + distance * cos thetaRad, py + distance * sin thetaRad)

drawLSystem l@(LSystem { grow, angle, representation }) =
  draw angle (fromIntegral grow) $ instructions l

mainLSystem :: IO ()
mainLSystem = do
  -- putStrLn $ foldMap show $ state $ step 3 kochCurve
  let lsys = plant
  let i =  2
  let pic = drawLSystem $ step i lsys
  createDisplay (name lsys) pic
  

------ EXAMPLES BELOW HERE --------


-- variables : A B
-- constants : none
-- axiom  : A
-- rules  : (A → AB), (B → A)
algae = LSystem
  { name = "algae"
  , state = [V "A"]
  , rules
  , grow = 10
  , angle = 90
  , representation = reprRules
  }
  where
    rules (V "A") = vars "AB"
    rules (V "B") = vars "A"
    rules (V _) = []
    rules (C _) = []
    reprRules _ = [Stay]
    vars = map V . r
    constants = map C . r


-- A variant of the Koch curve which uses only right angles.

-- variables : F
-- constants : + −
-- start  : F
-- rules  : (F → F+F−F−F+F)
-- Here, F means "draw forward", + means "turn left 90°", and − means "turn right 90°"
kochCurve = LSystem
  { name = "sierpinski"
  , state = [f]
  , rules
  , grow = 10
  , angle = 90.0
  , representation = reprRules
  }
  where
    m = C "-"
    p = C "+"
    f = V "F"
    rules (V "F") = [f,p,f,m,f,m,f,p,f]
    rules (V _) = []
    rules (C "+") = [p]
    rules (C "-") = [m]
    reprRules (V "F") = [Forward]
    reprRules (C "-") = [RotateRight]
    reprRules (C "+") = [RotateLeft]

-- -- The Sierpinski triangle drawn using an L-system.
--
-- -- variables : F G
-- -- constants : + −
-- -- state  : F−G−G
-- -- rules  : (F → F−G+F+G−F), (G → GG)
-- -- angle  : 120°
-- -- Here, F means "draw forward", G means "draw forward", + means "turn left by angle", and − means "turn right by angle".
sierpinski = LSystem
  { name = "sierpinski"
  , state = [f,m,g,m,g]
  , rules
  , grow = 10
  , angle = 120.0
  , representation = reprRules
  }
  where
    m = C "-"
    f = V "F"
    g = V "G"
    p = C "+"
    rules (V "F") = [f,m,g,p,f,p,g,m,f]
    rules (V "G") = [g,g]
    rules (V _) = []
    rules (C "-") = [m]
    rules (C "+") = [p]
    reprRules (V "F") = [Forward]
    reprRules (V "G") = [Forward]
    reprRules (C "-") = [RotateRight]
    reprRules (C "+") = [RotateLeft]

-- -- The dragon curve drawn using an L-system.

-- -- variables : F G
-- -- constants : + −
-- -- state  : F
-- -- rules  : (F → F+G), (G → F-G)
-- -- angle  : 90°
-- -- Here, F and G both mean "draw forward", + means "turn left by angle", and − means "turn right by angle".
dragon = LSystem
  { name = "dragon"
  , state = [f]
  , rules
  , grow = 10
  , angle = 90.0
  , representation = reprRules
  }
  where
    m = C "-"
    f = V "F"
    g = V "G"
    p = C "+"
    rules (V "F") = [f,p,g]
    rules (V "G") = [f,m,g]
    rules (V _) = []
    rules (C "+") = [p]
    rules (C "-") = [m]
    reprRules (V "F") = [Forward]
    reprRules (V "G") = [Forward]
    reprRules (C "-") = [RotateRight]
    reprRules (C "+") = [RotateLeft]

-- Example 7: Fractal plant
-- variables : X F
-- constants : + − [ ]
-- start  : X
-- rules  : (X → F+[[X]-X]-F[-FX]+X), (F → FF)
-- angle  : 25°
-- Here, F means "draw forward", − means "turn right 25°", and + means "turn left 25°". X does not correspond to any drawing action and is used to control the evolution of the curve. The square bracket "[" corresponds to saving the current values for position and angle, which are restored when the corresponding "]" is executed.

plant = LSystem
  { name = "plant"
  , state = [V "X"]
  , rules
  , grow = 10
  , angle = 25.0
  , representation = reprRules
  }
  where
    constants = T.chunksOf 1 "+-[]"
    variables = T.chunksOf 1 "FX"
    f s = if s `elem` constants then [C s] else rules (V s)
    r = concat . map f . T.chunksOf 1
    rules (V "F") = r "FF"
    rules (V "X") = r "F+[[X]-X]-F[-FX]+X"
    rules (V _) = []
    rules (C _) = error "shouldn't hit this"
    reprRules (V "F") = [Forward]
    reprRules (V "X") = [ForwardNoDraw]
    reprRules (C "-") = [RotateRight]
    reprRules (C "+") = [RotateLeft]
    reprRules (C "[") = [Push]
    reprRules (C "]") = [Pop]
    reprRules _ = []

-- dumb helper to split Text into separate characters
r :: T.Text -> [T.Text]
r = T.chunksOf 1