-- Drawing Hilbert curves with Tcl/Tk -- 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 Hilbert curves: h=5 left p = send (RLineTo (-h) 0) p right p = send (RLineTo h 0) p up p = send (RLineTo 0 (-h)) p down p = send (RLineTo 0 h) p data FigureType stroketype = Figure (FigureType stroketype) stroketype (FigureType stroketype) stroketype (FigureType stroketype) stroketype (FigureType stroketype) 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 draw (Figure f1 s1 f2 s2 f3 s3 f4) order p = if order==0 then success else draw f1 (order-1) p &> s1 p &> draw f2 (order-1) p &> s2 p &> draw f3 (order-1) p &> s3 p &> draw f4 (order-1) p hilbert i x y wpr | let pp free in newObject plotter ((x,y),wpr) pp & (draw fa i pp &> send Final pp) = done hilbert_tk = TkCol [] [ TkLabel [TkText "Drawing a Hilbert curve", TkRef lt, TkBackground "red"], TkCanvas [TkRef cref, TkHeight 330, TkWidth 330], TkRow [] (map (\o -> TkButton (drawCurve o) [TkText (show o)]) [1,2,3,4,5,6]), TkButton tkExit [TkText "Stop"]] where cref,lt free drawCurve o wp = tkSetValue lt ("Hilbert curve of order "++show o) wp >> hilbert o 320 10 (wp,(cref,"red")) main = runWidget "Hilbert Demo" hilbert_tk