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)