-- Drawing Hilbert curves in a canvas GUI

import Data.IORef
import Graphics.UI

---------------------------------------------------------------------
-- An implementation of a plotter.
-- A call (plotter pos gport wref color (tx,ty)) moves the plotter by (tx,ty)
-- and draws a line in canvas widget wref on GUI port gport (pos keeps
-- the internal plotter state, i.e., current coordinates).

plotter :: IORef (Int,Int) -> GuiPort -> WidgetRef -> String -> (Int,Int)
                                                             -> IO ()
plotter pos gport wref color (tx,ty) = do
  (x,y) <- readIORef pos
  addCanvas wref [CLine [(x,y),(x+tx,y+ty)] ("-fill "++color)] gport
  writeIORef pos (x+tx,y+ty)

---------------------------------------------------------------------

-- drawing Hilbert curves:
h :: Int
h = 5

left, right, up, down :: ((Int,Int) -> a) -> a
left  p = p (-h,0)
right p = p (h,0)
up    p = p (0,-h)
down  p = p (0,h)

data FigureType stroketype = Figure (FigureType stroketype) stroketype
                                    (FigureType stroketype) stroketype
                                    (FigureType stroketype) stroketype
                                    (FigureType stroketype)

fa, fb, fc, fd :: FigureType (((Int,Int) -> a) -> a)
fa = Figure fd left  fa down  fa right fb
fb = Figure fc up    fb right fb down  fa
fc = Figure fb right fc up    fc left  fd
fd = Figure fa down  fd left  fd up    fc


drawHilbert :: a -> Int -> FigureType (a -> IO ()) -> IO ()
drawHilbert p order (Figure f1 s1 f2 s2 f3 s3 f4) =
  if order==0
    then return ()
    else do drawHilbert p (order-1) f1
            s1 p
            drawHilbert p (order-1) f2
            s2 p
            drawHilbert p (order-1) f3
            s3 p
            drawHilbert p (order-1) f4


hilbertWidget :: Widget
hilbertWidget =
  Col [] [
    Label [Text "Drawing a Hilbert curve", WRef lt, Background "red"],
    Canvas [WRef cref, Height 330, Width 330],
    Row [] (map (\o -> Button (drawCurve o) [Text (show o)]) [1..6]),
    Button exitGUI [Text "Stop"]]
 where
  cref,lt free

  drawCurve o gport = do
    setValue lt ("Hilbert curve of order "++show o) gport
    pos <- newIORef (320,10)
    drawHilbert (plotter pos gport cref "red") o fa

main :: IO ()
main = runGUI "Hilbert Demo" hilbertWidget