{-
    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)