picolisp-gtk-server

picoLisp gtk-server interface
git clone https://logand.com/git/picolisp-gtk-server.git/
Log | Files | Refs

gtk-mandelbrot.l (5453B)


      1 # picoLisp + gtk-server example
      2 # 26feb2009 Tomas Hlavaty
      3 # $ ~/picolisp/p gtk-mandelbrot.l -bye
      4 # requires http://logand.com/gtk/gtk.l
      5 # based on http://www.turtle.dds.nl/newlisp/fractal.lsp
      6 
      7 (load "gtk.l")
      8 
      9 # Callback to exit program
     10 (de Exit_Prog ()
     11    (gtk_exit 0) )
     12 
     13 # Callback to clear canvas
     14 (de Clear_Canvas ()
     15    (gdk_color_parse "#ffffff" COLOR)
     16    (gdk_gc_set_rgb_fg_color GC COLOR)
     17    (gdk_draw_rectangle PIX GC 1 0 0 450 265)
     18    (gdk_color_parse "#000000" COLOR)
     19    (gdk_gc_set_rgb_fg_color GC COLOR)
     20    (gdk_draw_layout PIX GC 120 240 LAYOUT)
     21    (gtk_widget_queue_draw IMAGE) )
     22 
     23 (setq *Scl 6)
     24 
     25 # TODO based on http://logand.com/picoWiki/mandelbrot
     26 (de mandelbrotPoint (X Y N)
     27    (let (X0 X Y0 Y I 0)
     28       (while (and (< I N)
     29                 (<= (+ (*/ X X 1.0) (*/ Y Y 1.0)) 4.0) )
     30          (let (Xx (+ X0 (- (*/ X X 1.0) (*/ Y Y 1.0)))
     31                Yy (+ Y0 (*/ 2 X Y 1.0)) )
     32             (setq X Xx Y Yy) )
     33          (inc 'I) )
     34       I ) )
     35 
     36 (de mandelbrot (X Y Sx Sy W H C)
     37    (let (N (- C 1)
     38          X1 (- X (/ Sx 2))
     39          Y1 (- Y (/ Sy 2)) )
     40       (for (J 0 (< J H) (inc J))
     41          (for (I 0 (< I W) (inc I))
     42             (let (X (+ X1 (*/ I Sx W))
     43                   Y (+ Y1 (*/ J Sy H)) )
     44                (pixel I J (mandelbrotPoint X Y N) C) ) )
     45          (row) ) ) )
     46 
     47 (de Draw_Fractal ()
     48    # Tell drawing is starting
     49    (gdk_color_parse "#000000" COLOR)
     50    (gdk_gc_set_rgb_fg_color GC COLOR)
     51    (gdk_draw_layout PIX GC 10 240 START)
     52    (gtk_widget_queue_draw IMAGE)
     53    # draw the fractal
     54    (mandelbrot -0.5 0 3.0 2.0 300 265 100)
     55    # Wipe wait text
     56    (gdk_color_parse "#ffffff" COLOR)
     57    (gdk_gc_set_rgb_fg_color GC COLOR)
     58    (gdk_draw_rectangle PIX GC 1 10 240 120 25)
     59    # Tell drawing is ready
     60    (gdk_color_parse "#000000" COLOR)
     61    (gdk_gc_set_rgb_fg_color GC COLOR)
     62    (gdk_draw_layout PIX GC 10 240 READY)
     63    (gtk_widget_queue_draw IMAGE) )
     64 
     65 (de pix (X Y C)
     66    (gdk_color_parse C COLOR)
     67    (gdk_gc_set_rgb_fg_color GC COLOR)
     68    (gdk_draw_point PIX GC X Y) )
     69 
     70 (de bw (N C)
     71    (let V (*/ 255 N C)
     72       (pack "#"
     73          (pad 2 (hex V))
     74          (pad 2 (hex V))
     75          (pad 2 (hex V)) ) ) )
     76    
     77 (de pixel (X Y N C)
     78    (let L '("#800000" "#800080" "#8000FF" "#808000"
     79             "#808080" "#8080FF" "#80FF00" "#80FF80"
     80             "#80FFFF" "#FF0000" "#FF0080" "#FF00FF"
     81             "#FF8000" "#FF8080" "#FF80FF" "#FFFF00" )
     82       (if (< N (- C 1))
     83          (pix X Y (nth L (+ (*/ 15 N (- C 1)) 1) 1))
     84 #         (pix I J (bw (rand 0 (- C 1)) C))
     85 #         (pix I J (bw N C))
     86          (pix X Y "#000000") ) ) )
     87 
     88 (de row ()
     89    (gtk_widget_queue_draw IMAGE)
     90    (gtk_main_iteration) )
     91          
     92 (de mainLoop @
     93    (let E 0 # TODO dispatch events automatically
     94       (until (prog
     95                 (setq E (gtk_server_callback 'wait))
     96                 (or (= E 'Exit_Prog) (= E WIN)) )
     97         (case E
     98            (Draw_Fractal (Draw_Fractal))
     99            (Clear_Canvas (Clear_Canvas)) )
    100            ) )
    101    (gtk_exit 0)
    102    (wait 200) ) # TODO remove this fix Could not delete FIFO. ERROR
    103    
    104 # Window
    105 (gtk_init 0 0)
    106 (set 'WIN (gtk_window_new 0))
    107 (gtk_window_set_title WIN "picoLisp fractal")
    108 (gtk_widget_set_size_request WIN 300 300)
    109 (gtk_window_set_position WIN 1)
    110 (gtk_window_set_resizable WIN 0)
    111 (gtk_server_connect WIN 'delete-event 'Exit_Prog)
    112 # Create widget to display image
    113 (set 'IMAGE (gtk_image_new))
    114 # Create eventbox to catch mouseclick
    115 (set 'EBOX (gtk_event_box_new))
    116 (gtk_container_add EBOX IMAGE)
    117 # Separator
    118 (set 'SEP (gtk_hseparator_new))
    119 # Action button
    120 (set 'ACTION_BUTTON (gtk_button_new_with_label "Draw!"))
    121 (gtk_widget_set_size_request ACTION_BUTTON 75 30)
    122 (gtk_server_connect ACTION_BUTTON 'clicked 'Draw_Fractal)
    123 # Clear button
    124 (set 'CLEAR_BUTTON (gtk_button_new_with_label "Clear"))
    125 (gtk_widget_set_size_request CLEAR_BUTTON 75 30)
    126 (gtk_server_connect CLEAR_BUTTON 'clicked 'Clear_Canvas)
    127 # Exit button
    128 (set 'EXIT_BUTTON (gtk_button_new_with_label "Exit"))
    129 (gtk_widget_set_size_request EXIT_BUTTON 75 30)
    130 (gtk_server_connect EXIT_BUTTON 'clicked 'Exit_Prog)
    131 # Now arrange widgets on window using boxes
    132 (set 'HBOX (gtk_hbox_new 0 0))
    133 (gtk_box_pack_start HBOX CLEAR_BUTTON 0 0 1)
    134 (gtk_box_pack_start HBOX ACTION_BUTTON 0 0 1)
    135 (gtk_box_pack_end HBOX EXIT_BUTTON 0 0 1)
    136 (set 'VBOX (gtk_vbox_new 0 0))
    137 (gtk_box_pack_start VBOX EBOX 0 0 1)
    138 (gtk_box_pack_start VBOX SEP 0 0 1)
    139 (gtk_box_pack_end VBOX HBOX 0 0 1)
    140 (gtk_container_add WIN VBOX)
    141 # Show all widgets
    142 (gtk_widget_show_all WIN)
    143 # Create the pixmap
    144 (set 'GDKWIN (gtk_widget_get_parent_window IMAGE))
    145 (set 'PIX (gdk_pixmap_new GDKWIN 300 265 -1))
    146 (set 'GC (gdk_gc_new PIX))
    147 (gtk_image_set_from_pixmap IMAGE PIX 0)
    148 # Allocate memory with some random widget for GdkColor
    149 (set 'COLOR (gtk_frame_new 'NULL))
    150 # Now set foreground and backgroundcolors to WHITE
    151 (gdk_color_parse "#ffffff" COLOR)
    152 (gdk_gc_set_rgb_bg_color GC COLOR)
    153 (gdk_gc_set_rgb_fg_color GC COLOR)
    154 # Clear the complete pixmap with WHITE
    155 (gdk_draw_rectangle PIX GC 1 0 0 300 265)
    156 # Set color to BLACK
    157 (gdk_color_parse "#000000" COLOR)
    158 (gdk_gc_set_rgb_fg_color GC COLOR)
    159 # Put some text on the canvas
    160 (set 'LAYOUT
    161 (gtk_widget_create_pango_layout IMAGE "Draw a fractal with picoLisp!") )
    162 (gdk_draw_layout PIX GC 120 240 LAYOUT)
    163 # Define start and finishing text
    164 (set 'START (gtk_widget_create_pango_layout IMAGE "Please wait..."))
    165 (set 'READY (gtk_widget_create_pango_layout IMAGE "Drawing ready."))
    166 # Update the IMAGE widget with the pixmap
    167 (gtk_widget_queue_draw IMAGE)
    168 #(gtk_main)
    169 (mainLoop)