-- Drawing Sierpinski 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 Sierpinski curves: h=3 left2 p = send (RLineTo (-(2*h)) 0) p right2 p = send (RLineTo (2*h) 0) p up2 p = send (RLineTo 0 (-(2*h))) p down2 p = send (RLineTo 0 (2*h)) p leftdown p = send (RLineTo (-h) h) p rightdown p = send (RLineTo h h) p leftup p = send (RLineTo (-h) (-h)) p rightup p = send (RLineTo h (-h)) p data FigureType stroketype = Figure (FigureType stroketype) stroketype (FigureType stroketype) stroketype (FigureType stroketype) stroketype (FigureType stroketype) 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 fa = Figure fa rightdown fb right2 fd rightup fa fb = Figure fb leftdown fc down2 fa rightdown fb fc = Figure fc leftup fd left2 fb leftdown fc fd = Figure fd rightup fa up2 fc leftup fd fs = Figure fa rightdown fb leftdown fc leftup fd -- rightup sierpinski i x y wpr | let pp free in newObject plotter ((x,y),wpr) pp & (draw fs i pp &> rightup pp &> send Final pp) = done sw = TkCol [] [ TkLabel [TkText "Drawing a Sierpinski curve", TkRef lt, TkBackground "red"], TkCanvas [TkRef cref, TkHeight 400, TkWidth 400], 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 ("Sierpinski curve of order "++show o) wp >> sierpinski o 10 10 (wp,(cref,"red")) main = runWidget "Sierpinski Demo" sw