{-
Copyright (C) 2006 Alex McLean
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}
module LSystem where
peano = "slllsllr"
--peano = "lrlrrlrsrlrrlrrslllsllrs"
findLevel :: Int -> Int -> Int
findLevel lsystemSize toMap = findLevel' lsystemSize toMap 1
findLevel' lsystemSize toMap level =
let w = findArea level lsystemSize in
if w < toMap
then findLevel' lsystemSize toMap (level + 1)
else level
findWidth :: Int -> Int -> Int
findWidth level size = (sqrtI $ size + 1) ^ level
findArea :: Int -> Int -> Int
findArea level size = (findWidth level size) ^ 2
fill level lsystem = midpoints $ map (\(_,x,y) -> (x,y)) $ follow (0, 0, 0) $ path level lsystem
flatten _ [] = []
flatten w ((x, y):xs) = (y * w + x) : (flatten w xs)
sqrtI :: Int -> Int
sqrtI a = ceiling $ sqrt $ fromIntegral a
midpoints [] = []
midpoints (a:[]) = []
midpoints (a:b:xs) = (midpoint2D a b) : (midpoints (b:xs))
-- this takes the midpoint of each pair of points on the path of the
-- curve, translating it from a kind of diagonal configuration to a
-- square one
midpoint2D (x,y) (x',y') = (min x x', min y y')
follow coord [] = [coord]
follow coord (instruction:instructions) =
coord : (follow (move instruction coord) instructions)
path 0 _ = "s"
path level lsystem = twist lsystem $ path (level - 1) lsystem
-- my more 'efficient' version which actually seems less efficient
-- path :: Int -> [Char] -> [Char]
-- path depth lsystem = 's' : path' depth lsystem
-- path' 0 _ = []
-- path' depth lsystem = (foldl (++) "" $ map (\x -> (path' (depth-1) lsystem) ++ (x:[])) lsystem) ++ (path' (depth-1) lsystem)
twist :: [a] -> [a] -> [a]
twist lsystem = concatMap (: lsystem)
move :: Char -> (Int, Int, Int) -> (Int, Int, Int)
move 's' position = step position
move instruction (direction, x, y) =
move 's' ((turn instruction direction), x, y)
turn :: Char -> Int -> Int
turn 'l' direction = (direction+3) `mod` 4
turn 'r' direction = (direction+1) `mod` 4
step :: (Int, Int, Int) -> (Int, Int, Int)
step (0, x, y) = (0, x+1, y+1 )
step (1, x, y) = (1, x-1, y+1)
step (2, x, y) = (2, x-1, y-1)
step (3, x, y) = (3, x+1, y-1)