home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Environments / Clean 1.2.4 / IO Examples / Mandelbrot / FractalDemo.icl < prev    next >
Encoding:
Text File  |  1996-12-18  |  13.1 KB  |  347 lines  |  [TEXT/3PRM]
  1. module FractalDemo
  2.  
  3. /*
  4.     An interactive fractal drawing program.
  5.     
  6.     This program uses the 0.8 I/O library.
  7.     
  8.     This program requires a system with at least 256 colors. 
  9.     To really create beautiful fractals in a reasonable time 
  10.     you need a system with mathematical co-processor.
  11.     
  12.     Run the program using the "No Console" option (Application options).
  13. */
  14.  
  15. import StdInt, StdMisc, StdString, StdBool, StdReal, StdArray, StdTuple
  16. import Mandelbrot, deltaDialog, deltaControls
  17.     
  18. ::    ZoomFunction :== ZoomState -> Area -> Area 
  19.  
  20. Colour1 :== (0,99,4,99,2,60)
  21. Colour2 :== (4,99,0,99,2,75)
  22. Colour3 :== (4,99,2,70,0,99)
  23. Colour4 :== (0,80,1,80,3,60)
  24. Colour5 :== (2,99,0,99,1,99)
  25.  
  26. Start :: *World -> *World
  27. Start world
  28. #    (events,world)
  29.                 = OpenEvents world
  30.     (_,events)    = StartIO [window, menu, timer] InitState [] events
  31.     world        = CloseEvents events world
  32. =    world
  33. where
  34.     window        = WindowSystem
  35.                     [    FixedWindow MyWindow MyPos "Fractal Demo" 
  36.                             ((0,0),(ScreenWidth, ScreenHeight))
  37.                             FractalUpdate
  38.                                 [    GoAway Quit
  39.                                 ,    Mouse Unable (Track ZoomInArea)
  40.                                 ]
  41.                     ]
  42.     menu        = MenuSystem [file, options, commands]
  43.     file        = PullDownMenu FileID "File" Able
  44.                     [    MenuItem QuitID "Quit" (Key 'Q') Able Quit
  45.                     ]
  46.     options        = PullDownMenu OptionsID "Options" Able
  47.                     [    SubMenuItem FixedDepthsID "Fixed depths" Able 
  48.                         [    MenuRadioItems Depth128ID
  49.                             [    MenuRadioItem Depth32ID   "32"        NoKey Able (DefDepth 32)
  50.                             ,    MenuRadioItem Depth64ID   "64"        NoKey Able (DefDepth 64)
  51.                             ,    MenuRadioItem Depth128ID  "128"        NoKey Able (DefDepth 128)
  52.                             ,    MenuRadioItem Depth256ID  "256"        NoKey Able (DefDepth 256)
  53.                             ,    MenuRadioItem Depth512ID  "512"        NoKey Able (DefDepth 512)
  54.                             ,    MenuRadioItem Depth1024ID "1024"    NoKey Able (DefDepth 1024)
  55.                             ]
  56.                         ]
  57.                     ,    MenuSeparator
  58.                     ,    SubMenuItem AreasID "Predefined Areas" Able 
  59.                         [    CheckMenuItem    Area1ID "normal mandelbrot"
  60.                                             NoKey Able Mark      (DefArea Area1ID {center=(0.75,0.0),width=3.0,height=2.0})
  61.                         ,    CheckMenuItem    Area2ID "head"
  62.                                             NoKey Able NoMark (DefArea Area2ID {center=(1.26,0.0),width=1.0,height=0.7})
  63.                         ,    CheckMenuItem    Area3ID "spike"
  64.                                             NoKey Able NoMark (DefArea Area3ID {center=(1.54,0.0),width=0.20,height=0.14})
  65.                         ,    CheckMenuItem    Area4ID "spike detail"
  66.                                             NoKey Able NoMark (DefArea Area4ID {center=(1.4814,-0.0013),width=0.0366,height=0.0278})
  67.                         ,    CheckMenuItem    Area5ID "back valley"
  68.                                             NoKey Able NoMark (DefArea Area5ID {center=(-0.2963,-0.0152),width=0.1057,height=0.0926})
  69.                         ,    CheckMenuItem    Area6ID "head valley"
  70.                                             NoKey Able NoMark (DefArea Area6ID {center=(0.8,-0.2),width=0.37,height=0.29})
  71.                         ,    CheckMenuItem    Area7ID "antenna"
  72.                                             NoKey Able NoMark (DefArea Area7ID {center=(0.9203,-0.2889),width=0.0597,height=0.0606})
  73.                         ]
  74.                     ,    MenuSeparator
  75.                     ,    SubMenuItem FunctionsID "Mandelbrot Functions" Able
  76.                         [    MenuRadioItems Function1ID 
  77.                             [    MenuRadioItem Function1ID "z = z*z + c"   NoKey Able (DefaultFunction MSquare)
  78.                             ,    MenuRadioItem Function2ID "z = z*z*z + c" NoKey Able (DefFunction MCube)
  79.                             ,    MenuRadioItem Function3ID "z = sin z + c" NoKey Able (DefFunction MSin)
  80.                             ,    MenuRadioItem Function4ID "z = cos z + c" NoKey Able (DefFunction MCos)
  81.                             ,    MenuRadioItem Function5ID "z = exp z + c" NoKey Able (DefFunction MExp)
  82.                             ]
  83.                         ]
  84.                     ,    MenuSeparator
  85.                     ,    SubMenuItem ColoursID "Predefined Palettes" Able 
  86.                         [    MenuRadioItems Colour1ID
  87.                             [    MenuRadioItem Colour1ID "Red"        NoKey Able (SetColour Colour1)
  88.                             ,    MenuRadioItem Colour2ID "Green"      NoKey Able (SetColour Colour2)
  89.                             ,    MenuRadioItem Colour3ID "Blue"       NoKey Able (SetColour Colour3)
  90.                             ,    MenuRadioItem Colour4ID "Camouflage" NoKey Able (SetColour Colour4)
  91.                             ,    MenuRadioItem Colour5ID "Pastel"     NoKey Able (SetColour Colour5)
  92.                             ]
  93.                         ]
  94.                     ,    MenuItem 1000 "Set Palette..." (Key 'P') Able SetPalette
  95.                     ]
  96.     commands    = PullDownMenu CommandsID "Commands" Able
  97.                     [    MenuItem DrawID     "Draw Mandelbrot" (Key 'M') Able    DoMandelDraw
  98.                     ,    MenuSeparator
  99.                     ,    MenuItem ZoomInID   "Zoom in"         (Key 'Z') Unable (DoZoomFractal ZoomInArea)
  100.                     ,    MenuItem ZoomOutID  "Zoom out"        (Key 'O') Unable (DoZoomFractal ZoomOutArea)
  101.                     ,    MenuSeparator
  102.                     ,    MenuItem StopDrawID "Halt Drawing"    (Key 'S') Unable DoHaltDrawing
  103.                     ,    MenuItem ContinueID "Continue Drawing" NoKey    Unable DoContinueDrawing
  104.                     ]
  105.     timer        = TimerSystem [Timer TimerID Unable 0 DrawFractal]
  106.  
  107. InitState :: *FractalState
  108. InitState
  109. =    {    funstate    = {    area    = {center=(0.75,0.0),width=3.0,height=2.0}
  110.                       ,    colours    = Colour1
  111.                       ,    depth    = 128
  112.                       ,    fun        = MSquare
  113.                       }
  114.     ,    drawstate    = {    layer    = 0
  115.                         ,    grain    = 0
  116.                         ,    line    = 0
  117.                         }
  118.     ,    zoomstate    = ((0,0),(0,0))
  119.     }
  120.  
  121. /*    Real update:
  122. */
  123.  
  124. FractalUpdate :: UpdateArea *FractalState -> (*FractalState, [DrawFunction])
  125. FractalUpdate [] state
  126. =    (state,[])
  127. FractalUpdate _ state=:{drawstate={layer=0,grain=0,line=0}}
  128. =    (state,[])
  129. FractalUpdate upd_area state
  130. =    FractalUpdate` upd_area state
  131. where
  132.     FractalUpdate` :: UpdateArea *FractalState -> (*FractalState, [DrawFunction])
  133.     FractalUpdate` [first:rest] state
  134.     #    (state, update_area) = UpdateFractalArea first state
  135.         (state, update_rest) = FractalUpdate` rest state
  136.     =    (state, [update_area:update_rest])
  137.     FractalUpdate` _ state
  138.     =    (state,[])
  139.  
  140.  
  141. /*    File menu function:
  142. */
  143.  
  144. Quit :: *FractalState IO -> (*FractalState, IO)
  145. Quit state io = (state, QuitIO io)
  146.  
  147.  
  148. /*    Options menu functions:
  149. */
  150.  
  151. DefDepth :: CalcDepth *FractalState IO -> (*FractalState, IO)
  152. DefDepth depth state io
  153. =    (SetCalcDepth depth state,io)
  154.  
  155. DefArea :: MenuItemId Area *FractalState IO -> (*FractalState, IO)
  156. DefArea id area state io 
  157. =    (SetArea area state,MarkMenuItems [id] (UnmarkAreas io))
  158.  
  159. DefFunction :: FractalFunction *FractalState IO -> (*FractalState, IO)
  160. DefFunction func state io
  161. =    (SetFFunction func state,DisableMenuItems [Area1ID,Area2ID,Area3ID,Area4ID,Area5ID,Area6ID,Area7ID] io)
  162.  
  163. DefaultFunction :: FractalFunction *FractalState IO -> (*FractalState, IO)
  164. DefaultFunction func state io
  165. =    (SetFFunction func state,EnableMenuItems [Area1ID,Area2ID,Area3ID,Area4ID,Area5ID,Area6ID,Area7ID] io)
  166.  
  167. SetColour :: Colours *FractalState IO -> (*FractalState, IO)
  168. SetColour colour=:(rd,ri,gd,gi,bd,bi) state io
  169. =    (    SetNrOfColours colour state
  170.     ,    ChangeDialog 1
  171.               [    ChangeSliderBar 12 (rd*10+5), ChangeDynamicText 13 (toString rd)
  172.               ,    ChangeSliderBar 22 ri       , ChangeDynamicText 23 (toString ri)
  173.               ,    ChangeSliderBar 32 (gd*10+5), ChangeDynamicText 33 (toString gd)
  174.               ,    ChangeSliderBar 42 gi       , ChangeDynamicText 43 (toString gi)
  175.               ,    ChangeSliderBar 52 (bd*10+5), ChangeDynamicText 53 (toString bd)
  176.               ,    ChangeSliderBar 62 bi       , ChangeDynamicText 63 (toString bi)
  177.               ]    io
  178.     )
  179.  
  180. SetPalette :: *FractalState IO -> (*FractalState, IO)
  181. SetPalette state=:{funstate={colours=(rd,ri,gd,gi,bd,bi)}} io
  182. =    (state,OpenDialog dialog io)
  183. where
  184.     dialog    = CommandDialog 1 "Palette" [ItemSpace (Pixel 6) (Pixel 12)] 1
  185.                 [    ColourText        11 Left                        RedColour "Depth:"
  186.                 ,    PaletteSlider    12 (RightTo 11)                (rd*10+5) 10
  187.                 ,    DynamicText        13 (RightTo 12) (Pixel 30)    (toString rd)
  188.                 ,    ColourText        21 (YOffset 11 (Pixel 6))    RedColour "Brightness:"
  189.                 ,    PaletteSlider    22 (RightTo 21)                ri 1
  190.                 ,    DynamicText        23 (RightTo 22) (Pixel 30)    (toString ri)
  191.                 ,    ColourText        31 Left                        GreenColour "Depth:"
  192.                 ,    PaletteSlider    32 (RightTo 31)                (gd*10+5) 10
  193.                 ,    DynamicText        33 (RightTo 32) (Pixel 30)    (toString gd)
  194.                 ,    ColourText        41 (YOffset 31 (Pixel 6))    GreenColour "Brightness:"
  195.                 ,    PaletteSlider    42 (RightTo 41)                gi 1
  196.                 ,    DynamicText        43 (RightTo 42) (Pixel 30)    (toString gi)
  197.                 ,    ColourText        51 Left                        BlueColour "Depth:"
  198.                 ,    PaletteSlider    52 (RightTo 51) (bd*10+5)    10
  199.                 ,    DynamicText        53 (RightTo 52) (Pixel 30)    (toString bd)
  200.                 ,    ColourText        61 (YOffset 51 (Pixel 6))    BlueColour "Brightness:"
  201.                 ,    PaletteSlider    62 (RightTo 61)                bi 1
  202.                 ,    DynamicText        63 (RightTo 62) (Pixel 30)    (toString bi)
  203.                 ,    DialogButton    1  Center "OK" Able PaletteOK
  204.                 ]
  205.     
  206.     ColourText :: DialogItemId ItemPos Colour String -> DialogItem *FractalState IO
  207.     ColourText id pos col text
  208.     =    DialogIconButton id pos domain (DrawText ascent col text) Unable (\_ state io -> (state,io))
  209.     where
  210.         domain                        = ((0,0),(wid,ascent+descent+leading))
  211.         wid                            = FontStringWidth "Brightness:" dfont
  212.         (ascent,descent,_,leading)    = FontMetrics dfont
  213.         (_,dfont)                    = SelectFont font style size
  214.         (font,style,size)            = DefaultFont
  215.         
  216.         DrawText :: Int Colour String SelectState -> [DrawFunction]
  217.         DrawText y col text a = [SetPenColour col, MovePenTo (0,y), DrawString text]
  218.     
  219.     PaletteSlider :: DialogItemId ItemPos SliderPos Int -> DialogItem *FractalState IO
  220.     PaletteSlider id pos slider val
  221.     =    SliderBar id pos Able Horizontal slider 99 (ChangeValue id val)
  222.     where
  223.         ChangeValue :: DialogItemId Int DialogInfo (DialogState *FractalState IO) -> DialogState *FractalState IO
  224.         ChangeValue id val dinfo dstate
  225.                 = ChangeDynamicText (id+1) (toString pos) dstate
  226.         where
  227.             pos    = GetSliderPosition id dinfo / val
  228.     
  229.     PaletteOK :: DialogInfo *FractalState IO -> (*FractalState, IO)
  230.     PaletteOK dialog state io
  231.     =    (SetNrOfColours (rd,ri,gd,gi,bd,bi) state,ActivateWindow MyWindow io)
  232.     where
  233.         rd    = GetSliderPosition 12 dialog / 10
  234.         ri    = GetSliderPosition 22 dialog
  235.         gd    = GetSliderPosition 32 dialog / 10
  236.         gi    = GetSliderPosition 42 dialog
  237.         bd    = GetSliderPosition 52 dialog / 10
  238.         bi    = GetSliderPosition 62 dialog
  239.  
  240. /*    Commands Menu functions:
  241. */
  242.  
  243. DoZoomFractal :: ZoomFunction *FractalState IO -> (*FractalState,IO)
  244. DoZoomFractal zoomfunc state io 
  245. #    io    = EnableMouse            MyWindow                    io
  246.     io    = DisableTimer            TimerID                        io
  247.     io    = DisableMenus            [OptionsID,CommandsID]        io
  248.     io    = ChangeMouseFunction    MyWindow (Track zoomfunc)    io
  249. =    (state,io)
  250.  
  251. DoMandelDraw :: *FractalState IO -> (*FractalState,IO)
  252. DoMandelDraw state io 
  253. #    io    = EnableTimer        TimerID                            io
  254.     io    = DisableMenus        [OptionsID]                        io
  255.     io    = EnableMenuItems    [StopDrawID,ZoomInID,ZoomOutID]    io
  256.     io    = DisableMenuItems    [DrawID,ContinueID]                io
  257. =    (InitDrawState state,io)
  258.  
  259. DoHaltDrawing :: *FractalState IO -> (*FractalState,IO)
  260. DoHaltDrawing state io
  261. #    (state,io)    = DoStopDrawing        state            io
  262.     io            = EnableMenuItems    [ContinueID]    io
  263. =    (state,io)
  264.  
  265. DoContinueDrawing :: *FractalState IO -> (*FractalState,IO)
  266. DoContinueDrawing state io
  267. #    io    = EnableTimer        TimerID                            io
  268.     io    = DisableMenus        [OptionsID]                        io
  269.     io    = EnableMenuItems    [StopDrawID,ZoomInID,ZoomOutID]    io
  270.     io    = DisableMenuItems    [DrawID,ContinueID]                io
  271. =    (state,io)
  272.  
  273. // Zooming
  274. Track :: ZoomFunction MouseState *FractalState IO -> (*FractalState,IO)
  275. Track zoomfun (_,ButtonUp,_) state=:{funstate={area},zoomstate} io
  276. |    TooSmall zoom`    = (    state
  277.                       ,    ChangeIOState 
  278.                                 [    EnableMenus            [OptionsID,CommandsID]
  279.                                 ,    EnableMenuItems        [DrawID]
  280.                                 ,    DisableMenuItems    [StopDrawID]
  281.                                 ,    DrawInWindow        MyWindow [ReadyZoom zoomstate]
  282.                                 ]    io
  283.                       )
  284. |    otherwise        = (    InitDrawState (SetArea (zoomfun zoom` area) state)
  285.                       ,    ChangeIOState 
  286.                                 [    UnmarkAreas
  287.                                 ,    EnableMenus            [CommandsID]
  288.                                 ,    DisableMenuItems    [DrawID,ContinueID]
  289.                                 ,    EnableMenuItems        [ZoomInID,ZoomOutID,StopDrawID]
  290.                                 ,    DisableMouse        MyWindow
  291.                                 ,    EnableTimer            TimerID
  292.                                 ,    DrawInWindow        MyWindow [ReadyZoom zoomstate]
  293.                                 ]    io
  294.                       )
  295. where
  296.     zoom`            = CorrectRect zoomstate
  297.     
  298.     CorrectRect :: Rectangle -> Rectangle
  299.     CorrectRect ((x1,y1),(x2,y2)) = ((min x1 x2,min y1 y2),(max x1 x2,max y1 y2))
  300.     
  301.     TooSmall :: Rectangle -> Bool
  302.     TooSmall ((x1,y1),(x2,y2)) = x2-x1<8 || y2-y1<8 
  303.     
  304.     ReadyZoom :: Rectangle Picture -> Picture
  305.     ReadyZoom rect p = SetPenNormal (DrawRectangle rect p)
  306. Track _ (point,ButtonStillDown,_) state=:{zoomstate} io
  307. |    last==point        = (    state,io)
  308. |    otherwise        = (    SetZoomState rect` state
  309.                       ,    DrawInWindow MyWindow [DrawFrame zoomstate rect`] io
  310.                       )
  311.                     with
  312.                         rect`    = (base,point)
  313. where
  314.     (base,last)        = zoomstate
  315.     
  316.     DrawFrame :: Rectangle Rectangle Picture -> Picture
  317.     DrawFrame oldrect rect p = DrawRectangle rect (DrawRectangle oldrect p)
  318. Track _ (point,ButtonDown,_) state io
  319.                     = (SetZoomState rect` state,DrawInWindow MyWindow [ZoomFrame rect`] io)
  320. where
  321.     rect`            = (point,point)
  322.     
  323.     ZoomFrame :: Rectangle Picture -> Picture
  324.     ZoomFrame rect p = DrawRectangle rect (SetPenMode XorMode (SetPenColour BlackColour p))
  325. Track _ _ state io    = (state,io)
  326.  
  327. ZoomInArea :: ZoomState Area -> Area
  328. ZoomInArea ((x1,y1),(x2,y2)) {center=(xc,yc),width,height}
  329. =    {center=(centerx,centery),width=newwidth,height=newheight}
  330. where
  331.     centerx        = xc + width /toReal ScreenWidth * (toReal (x1+x2-ScreenWidth) / 2.0)   
  332.     centery        = yc + height/toReal ScreenHeight* (toReal (y1+y2-ScreenHeight)/ 2.0) 
  333.     newwidth    = width *(toReal (x2-x1) / toReal ScreenWidth )
  334.     newheight    = height*(toReal (y2-y1) / toReal ScreenHeight)
  335.  
  336. ZoomOutArea :: ZoomState Area -> Area
  337. ZoomOutArea ((x1,y1),(x2,y2)) {center=(xc,yc),width,height}
  338. =    {center=(centerx,centery),width=newwidth,height=newheight}
  339. where
  340.     centerx        = xc - newwidth / toReal ScreenWidth  * (toReal (x1+x2-ScreenWidth) / 2.0)   
  341.     centery        = yc - newheight/ toReal ScreenHeight * (toReal (y1+y2-ScreenHeight)/ 2.0) 
  342.     newwidth    = toReal ScreenWidth /toReal (x2-x1)*width
  343.     newheight    = toReal ScreenHeight/toReal (y2-y1)*height
  344.  
  345. UnmarkAreas :: (IOState s) -> IOState s
  346. UnmarkAreas io = UnmarkMenuItems AreaIds io
  347.