-- The beauty of fractals:

-- with a "plotter" object which directly writes to Tcl/Tk:

import Tk
import Ports

---------------------------------------------------------------------
-- a plotter object: messages:
-- PlotTo x y wp: move plotter to position (x,y) and write line to wish wp
-- CurrentPos x y: unify x y with current plotter position
-- Final: terminate plotter

data PlotterMsg = RLineTo Int Int | Final

plotter :: ((Int,Int),(Port SP_Msg,(TkRefType,String))) -> [PlotterMsg]
                                                        -> Success
plotter _ (Final :_)  = success
plotter ((x,y),wpr) ((RLineTo tx ty) :ms) = 
    plotLine wpr [(x,y),(x+tx,y+ty)] &> plotter ((x+tx,y+ty),wpr) ms

plotLine (wport,(cref,color)) cs =
    tkCAddCanvas cref [TkLine cs ("-fill "++color)] wport


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

-- drawing fractal curves:

left  p h = send (RLineTo (-h) 0) p
right p h = send (RLineTo h 0)    p
up    p h = send (RLineTo 0 (-h)) p
down  p h = send (RLineTo 0 h)    p

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



fr = Figure right fr fu fd
fu = Figure up    fu fl fr
fd = Figure down  fd fr fl
fl = Figure left  fl fd fu


draw (Figure s f1 f2 f3) order diff p =
  if order==0 then s p diff
              else draw f1 (order-1) h     p &>
                   draw f2 (order-1) (h-1) p &>
                   draw f1 (order-1) h     p &>
                   draw f3 (order-1) (h-1) p &>
                   draw f1 (order-1) h     p &>
                   s p (diff-3*h)  -- to avoid rounding problems
  where h = diff `div` 3

draw_all order diff p = draw fr order diff p &>
                        draw fd order diff p &>
                        draw fl order diff p &>
                        draw fu order diff p


fractal i x y d wpr
 | let pp free in
   newObject plotter ((x,y),wpr) pp & (draw_all i d pp &> send Final pp)
 = done

fractal_tk =
  TkCol [] [
    TkLabel [TkText "Drawing a simple fractal curve:"],
    TkRow []
      ([TkLabel [TkText "Select the order of the fractal:"]] ++
       map (\o -> TkButton (drawFractal o) [TkText (show o)]) [2,3,4,5]),
    TkCanvas [TkRef cref, TkBackground "white", TkHeight 600, TkWidth 600],
    TkButton tkExit [TkText "Stop"]]

 where cref free

       drawFractal order wp = fractal order 150 150 300 (wp,(cref,color order))
 
       color order = if order==2 then "green" else
                     if order==3 then "blue"  else "red"


main = runWidget "Fractal Demo" fractal_tk