75 lines
1.8 KiB
Haskell
75 lines
1.8 KiB
Haskell
import Data.Tree (Tree (..))
|
|
|
|
---------------------- HILBERT CURVE ---------------------
|
|
|
|
hilbertTree :: Int -> Tree Char
|
|
hilbertTree n
|
|
| 0 < n = iterate go seed !! pred n
|
|
| otherwise = seed
|
|
where
|
|
seed = Node 'a' []
|
|
go tree
|
|
| null xs = Node c (flip Node [] <$> rule c)
|
|
| otherwise = Node c (go <$> xs)
|
|
where
|
|
c = rootLabel tree
|
|
xs = subForest tree
|
|
|
|
|
|
hilbertPoints :: Int -> Tree Char -> [(Int, Int)]
|
|
hilbertPoints w = go r (r, r)
|
|
where
|
|
r = quot w 2
|
|
go r xy tree
|
|
| null xs = centres
|
|
| otherwise = concat $ zipWith (go d) centres xs
|
|
where
|
|
d = quot r 2
|
|
f g x = g xy + (d * g x)
|
|
centres =
|
|
((,) . f fst)
|
|
<*> f snd <$> vectors (rootLabel tree)
|
|
xs = subForest tree
|
|
|
|
|
|
--------------------- PRODUCTION RULE --------------------
|
|
|
|
rule :: Char -> String
|
|
rule c =
|
|
case c of
|
|
'a' -> "daab"
|
|
'b' -> "cbba"
|
|
'c' -> "bccd"
|
|
'd' -> "addc"
|
|
_ -> []
|
|
|
|
vectors :: Char -> [(Int, Int)]
|
|
vectors c =
|
|
case c of
|
|
'a' -> [(-1, 1), (-1, -1), (1, -1), (1, 1)]
|
|
'b' -> [(1, -1), (-1, -1), (-1, 1), (1, 1)]
|
|
'c' -> [(1, -1), (1, 1), (-1, 1), (-1, -1)]
|
|
'd' -> [(-1, 1), (1, 1), (1, -1), (-1, -1)]
|
|
_ -> []
|
|
|
|
|
|
--------------------------- TEST -------------------------
|
|
|
|
main :: IO ()
|
|
main = do
|
|
let w = 1024
|
|
putStrLn $ svgFromPoints w $ hilbertPoints w (hilbertTree 6)
|
|
|
|
svgFromPoints :: Int -> [(Int, Int)] -> String
|
|
svgFromPoints w xys =
|
|
let sw = show w
|
|
points =
|
|
(unwords . fmap (((<>) . show . fst) <*> ((' ' :) . show . snd))) xys
|
|
in unlines
|
|
[ "<svg xmlns=\"http://www.w3.org/2000/svg\"",
|
|
unwords
|
|
["width=\"512\" height=\"512\" viewBox=\"5 5", sw, sw, "\"> "],
|
|
"<path d=\"M" ++ points ++ "\" ",
|
|
"stroke-width=\"2\" stroke=\"red\" fill=\"transparent\"/>",
|
|
"</svg>"
|
|
]
|