home *** CD-ROM | disk | FTP | other *** search
- ; *********************************************************************
-
- ; A set of procedures for making images of the Mandelbrot set. When
- ; loaded, this file adds a menu to the command window. Just select the
- ; type of image you wish to make.
- ; Each of these procedures opens its own screen, sets up its default
- ; settings, then calls the procedure "pixelmap" to render the image.
- ; "pixelmap" takes a procedure definition list as its input which is used
- ; to find the color for each pixel in the image.
-
- ; "pixelmap" includes the following menu options:
-
- ; Project
- ; Load
- ; Save
- ; Stop
- ; Quit
- ; New Image
- ; New Region
- ; Edit Specs
- ; Import Region
- ; Tools
- ; Palette
- ; Mouse
- ; Select Region
- ; Title Bar
- ; No First Pass
-
- ; *********************************************************************
-
- make "mandelbrot [
- procedure [ [ ] [ :xoff :yoff :mag :limit :curve ]
- [ :save-list
- :i :zx :zy :tx :xx :yy ] ]
- recycle
- make "pixel-screen ( openscreen 3 4 [ \ Mandelbrot z^2+c ] )
- make "pixel-window ( openwindow :pixel-screen ( + 32 64 128 ) )
- make "i 1
- repeat 15
- [ setrgb :pixel-screen - 16 :i ( se 15 :i :i )
- make "i + :i 1 ]
- setrgb :pixel-screen 0 [ 0 0 0 ]
- if listp :xoff [ make "xoff 0 ] [ ]
- if listp :yoff [ make "yoff 0 ] [ ]
- if listp :mag [ make "mag 0.5 ] [ ]
- if listp :limit [ make "limit 40 ] [ ]
- if listp :curve [ make "curve 0.6 ] [ ]
- make "save-list [ xoff yoff mag limit curve
- color
- sx1 sy1 sx2 sy2 x xmag ymag ]
- pixelmap [
- procedure [ ]
- make "zx 0
- make "zy 0
- make "xx 0
- make "yy 0
- make "i 0
- while [ < + :xx :yy 4 ]
- [ make "tx + - :xx :yy :x
- make "zy + ( * 2 :zx :zy ) :y
- make "zx :tx
- make "xx * :zx :zx
- make "yy * :zy :zy
- if < :i :limit [ ] [ output 0 ]
- make "i + :i 1 ]
- if = 1 :i
- [ output 0 ]
- [ output - 15 * 14 power / :i :limit :curve ] ] ]
-
- ; *********************************************************************
-
- make "epsilon-cross [
- procedure [ [ ] [ :xoff :yoff :mag :limit :epsilon ]
- [ :save-list
- :i :zx :zy :tx :xx :yy ] ]
- recycle
- make "pixel-screen
- ( openscreen 3 2 [ \ Mandelbrot z^2+c Epsilon Cross ] )
- make "pixel-window ( openwindow :pixel-screen ( + 32 64 128 ) )
- setrgb :pixel-screen 1 [ 15 15 0 ]
- setrgb :pixel-screen 2 [ 15 0 15 ]
- setrgb :pixel-screen 3 [ 5 5 5 ]
- setrgb :pixel-screen 0 [ 0 0 0 ]
- if listp :xoff [ make "xoff 0 ] [ ]
- if listp :yoff [ make "yoff 0 ] [ ]
- if listp :mag [ make "mag 0.5 ] [ ]
- if listp :limit [ make "limit 40 ] [ ]
- if listp :epsilon [ make "epsilon 0.01 ] [ ]
- make "save-list [ xoff yoff mag limit epsilon
- color
- sx1 sy1 sx2 sy2 x xmag ymag ]
- pixelmap [
- procedure [ ]
- make "zx 0
- make "zy 0
- make "xx 0
- make "yy 0
- make "i 0
- while [ < + :xx :yy 4 ]
- [ make "tx + :x - :xx :yy
- make "zy + :y ( * 2 :zx :zy )
- make "zx :tx
- make "xx * :zx :zx
- make "yy * :zy :zy
- if < abs :zx :epsilon [ output 2 ] [ ]
- if < abs :zy :epsilon [ output 1 ] [ ]
- if < :i :limit [ ] [ output 0 ]
- make "i + :i 1 ]
- output 3 ] ]
-
- ; *********************************************************************
-
- make "level-curve [
- procedure [ [ ] [ :xoff :yoff :mag :limit :levels ]
- [ :save-list
- :i :zx :zy :tx :xx :yy :small :size ] ]
- recycle
- make "pixel-screen
- ( openscreen 3 2 [ \ Mandelbrot z^2+c Level Curve ] )
- make "pixel-window ( openwindow :pixel-screen ( + 32 64 128 ) )
- setrgb :pixel-screen 0 [ 0 0 0 ]
- setrgb :pixel-screen 1 [ 15 15 15 ]
- setrgb :pixel-screen 2 [ 5 5 5 ]
- setrgb :pixel-screen 3 [ 15 15 0 ]
- if listp :xoff [ make "xoff 0 ] [ ]
- if listp :yoff [ make "yoff 0 ] [ ]
- if listp :mag [ make "mag 0.5 ] [ ]
- if listp :limit [ make "limit 40 ] [ ]
- if listp :levels [ make "levels 40 ] [ ]
- make "save-list [ xoff yoff mag limit levels
- color
- sx1 sy1 sx2 sy2 x xmag ymag ]
- pixelmap [
- procedure [ ]
- make "zx 0
- make "zy 0
- make "xx 0
- make "yy 0
- make "size 0
- make "small 100
- make "i 0
- while [ < + :xx :yy 4 ]
- [ make "tx + :x - :xx :yy
- make "zy + :y ( * 2 :zx :zy )
- make "zx :tx
- make "xx * :zx :zx
- make "yy * :zy :zy
- make "size + :xx :yy
- if < :size :small [ make "small :size ] [ ]
- if < :i :limit
- [ ]
- [ output remainder int * :levels sqrt :small 2 ]
- make "i + :i 1 ]
- output 2 ] ]
-
- ; *********************************************************************
-
- make "z^3+z(c-1)-c [
- procedure [ [ ] [ :xoff :yoff :mag :limit :curve ]
- [ :save-list
- :i :zx :zy :tx :xx :yy ] ]
- recycle
- make "pixel-screen ( openscreen 3 4 [ \ z^3+z(c-1)-c ] )
- make "pixel-window ( openwindow :pixel-screen ( + 32 64 128 ) )
- make "i 1
- repeat 15
- [ setrgb :pixel-screen - 16 :i ( se 15 :i :i )
- make "i + :i 1 ]
- setrgb :pixel-screen 0 [ 0 0 0 ]
- if listp :xoff [ make "xoff 0 ] [ ]
- if listp :yoff [ make "yoff 0 ] [ ]
- if listp :mag [ make "mag 0.6 ] [ ]
- if listp :limit [ make "limit 40 ] [ ]
- if listp :curve [ make "curve 0.6 ] [ ]
- make "save-list [ xoff yoff mag limit curve
- color
- sx1 sy1 sx2 sy2 x xmag ymag ]
- pixelmap [
- procedure [ ]
- make "zx 0
- make "zy 0
- make "xx 0
- make "yy 0
- make "i 0
- while [ < + :xx :yy 4 ]
- [ make "tx ( - * :zx
- ( - + :xx :x
- * 3 :yy
- 1 )
- * :y :zy
- :x )
- make "zy - + * :y :zx
- * :zy
- - ( + :yy
- :x
- * 3 :xx )
- 1
- :y
- make "zx :tx
- make "xx * :zx :zx
- make "yy * :zy :zy
- if < :i :limit [ ] [ output 0 ]
- make "i + :i 1 ]
- if = 1 :i
- [ output 0 ]
- [ output - 15 * 14 power / :i :limit :curve ] ] ]
-
- ; *********************************************************************
-
- make "z^3-epsilon-cross [
- procedure [ [ ] [ :xoff :yoff :mag :limit :epsilon ]
- [ :save-list
- :i :zx :zy :tx :xx :yy ] ]
- recycle
- make "pixel-screen ( openscreen 3 2 [ \ z^3+z(c-1)-c Epsilon Cross ] )
- make "pixel-window ( openwindow :pixel-screen ( + 32 64 128 ) )
- setrgb :pixel-screen 1 [ 15 15 0 ]
- setrgb :pixel-screen 2 [ 15 0 15 ]
- setrgb :pixel-screen 3 [ 5 5 5 ]
- setrgb :pixel-screen 0 [ 0 0 0 ]
- if listp :xoff [ make "xoff 0 ] [ ]
- if listp :yoff [ make "yoff 0 ] [ ]
- if listp :mag [ make "mag 0.5 ] [ ]
- if listp :limit [ make "limit 40 ] [ ]
- if listp :epsilon [ make "epsilon 0.01 ] [ ]
- make "save-list [ xoff yoff mag limit epsilon
- color
- sx1 sy1 sx2 sy2 x xmag ymag ]
- pixelmap [
- procedure [ ]
- make "zx 0
- make "zy 0
- make "xx 0
- make "yy 0
- make "i 0
- while [ < + :xx :yy 4 ]
- [ make "tx ( - * :zx
- ( - + :xx :x
- * 3 :yy
- 1 )
- * :y :zy
- :x )
- make "zy - + * :y :zx
- * :zy
- - ( + :yy
- :x
- * 3 :xx )
- 1
- :y
- make "zx :tx
- make "xx * :zx :zx
- make "yy * :zy :zy
- if < abs :zx :epsilon [ output 2 ] [ ]
- if < abs :zy :epsilon [ output 1 ] [ ]
- if < :i :limit [ ] [ output 0 ]
- make "i + :i 1 ]
- output 3 ] ]
-
- ; *********************************************************************
-
- make "z^3-level-curve [
- procedure [ [ ] [ :xoff :yoff :mag :limit :levels ]
- [ :save-list
- :i :zx :zy :tx :xx :yy :small :size ] ]
- recycle
- make "pixel-screen ( openscreen 3 2 [ \ z^2+z(c-1)-c Level Curve ] )
- make "pixel-window ( openwindow :pixel-screen ( + 32 64 128 ) )
- setrgb :pixel-screen 0 [ 0 0 0 ]
- setrgb :pixel-screen 1 [ 15 15 15 ]
- setrgb :pixel-screen 2 [ 5 5 5 ]
- setrgb :pixel-screen 3 [ 15 15 0 ]
- if listp :xoff [ make "xoff 0 ] [ ]
- if listp :yoff [ make "yoff 0 ] [ ]
- if listp :mag [ make "mag 0.5 ] [ ]
- if listp :limit [ make "limit 40 ] [ ]
- if listp :levels [ make "levels 40 ] [ ]
- make "save-list [ xoff yoff mag limit levels
- color
- sx1 sy1 sx2 sy2 x xmag ymag ]
- pixelmap [
- procedure [ ]
- make "zx 0
- make "zy 0
- make "xx 0
- make "yy 0
- make "size 0
- make "small 100
- make "i 0
- while [ < + :xx :yy 4 ]
- [ make "tx ( - * :zx
- ( - + :xx :x
- * 3 :yy
- 1 )
- * :y :zy
- :x )
- make "zy - + * :y :zx
- * :zy
- - ( + :yy
- :x
- * 3 :xx )
- 1
- :y
- make "zx :tx
- make "xx * :zx :zx
- make "yy * :zy :zy
- make "size + :xx :yy
- if < :size :small [ make "small :size ] [ ]
- if < :i :limit
- [ ]
- [ output remainder int * :levels sqrt :small 2 ]
- make "i + :i 1 ]
- output 2 ] ]
-
- ; *********************************************************************
- ; pixelmap procedure-definition-list
-
- make "pixelmap [
- procedure [ [ :color ] [ ]
- [ :sx1 :sy1 :sx2 :sy2 :x :y :xmag :ymag
- :menu-list :menu :mitem :sub :window-menus :pixel-menus
- :title :mb :rx :ry :rsize :rsizeold :tdemon :rdemon ] ]
-
- make "tdemon [
- if if and namep "pixel-window namep "title
- [ = :pixel-window first getmouse ]
- [ whenmouse [ ] false ]
- [ ( intuition 7 :pixel-screen if :title [ 0 ] [ 1 ] )
- make "title not :title ]
- [ ] ]
- make "rdemon [
- if if and namep "pixel-window namep "title
- [ make "mb getmouse = :pixel-window first :mb ]
- [ whenmouse [ ] false ]
- [ make "rx item 2 :mb
- make "ry item 3 :mb
- make "rsize 1
- make "rsizeold 1
- setdrmode :pixel-window 2
- markrect :rx :ry :rsize
- dowhile
- [ make "mb mouse :pixel-window
- make "rsize if > abs - :rx first :mb
- int * 1.6 abs - :ry item 2 :mb
- [ abs - :rx first :mb ]
- [ int * 1.6 abs - :ry item 2 :mb ]
- if > 1 :rsize [ make "rsize 1 ] [ ]
- if = :rsize :rsizeold
- [ ]
- [ markrect :rx :ry :rsizeold
- markrect :rx :ry :rsize
- make "rsizeold :rsize ] ]
- [ = 1 item 3 :mb ]
- markrect :rx :ry :rsize
- setdrmode :pixel-window 0
- ( intuition 4 :pixel-window 2 1 0 ) ]
- [ ] ]
- make "title true
- whenmouse :tdemon
-
- setmenu :pixel-window [
- \ \ \ Project\ \ \
- [ \ \ Load\ ]
- [ \ \ Save ]
- [ \ \ Stop ]
- [ \ \ Quit ]
- \ \ \ New\ Image\ \ \
- [ \ \ New\ Region ]
- [ \ \ Edit\ Specs ]
- [ \ \ Import\ Region ]
- \ \ \ Tools\ \ \
- [ \ \ Palette ]
- [ \ \ Mouse
- [ \ \ Select\ Region ]
- [ \ \ Title\ Bar ] ]
- [ \ \ No\ First\ Pass ] ]
- ( intuition 3 :pixel-window 2 1 0 )
- ( intuition 3 :pixel-window 3 2 2 )
-
- make "window-menus [
- procedure [ [ :scr-menu ] ]
- if = :pixel-window first :scr-menu
- [ make "menu-list :scr-menu ]
- [ ] ]
-
- make "pixel-menus [
- if = :pixel-window first :menu-list
- [ make "mitem item 3 :menu-list
- make "sub item 4 :menu-list
- make "menu item 2 :menu-list
- cond
- [ [ = 1 :menu ]
- [ cond
- [ [ = 1 :mitem ]
- [ recycle
- make "menu ( filerequest "Load\ Image\ \ -\ )
- intuition 6 :pixel-screen
- if emptyp :menu
- [ ]
- [ ( intuition 7 :pixel-screen 0 )
- ( intuition 3 :pixel-window 2 1 0 )
- loadimage :pixel-window :menu
- if :title [ ( intuition 7 :pixel-screen 1 ) ] [ ]
- load word :menu ".specs ] ]
- [ = 2 :mitem ]
- [ recycle
- make "menu ( filerequest "Save\ Image\ \ -\ )
- intuition 6 :pixel-screen
- if emptyp :menu
- [ ]
- [ ( intuition 7 :pixel-screen 0 )
- saveimage :pixel-window :menu
- if :title [ ( intuition 7 :pixel-screen 1 ) ] [ ]
- save word :menu ".specs :save-list ] ]
- [ = 3 :mitem ] [ stop ]
- [ = 4 :mitem ]
- [ closescreen :pixel-screen
- erase [ pixel-window pixel-screen ]
- whenmouse [ ]
- stop ] ] ]
- [ = 2 :menu ]
- [ cond
- [ [ = 1 :mitem ]
- [ make "xoff + :xoff / - :rx 320 :xmag
- make "yoff + :yoff / - 200 :ry :ymag
- make "mag * :mag / 320 :rsize ]
- [ = 2 :mitem ]
- [ intuition 6 @0
- recycle
- edit :save-list
- intuition 6 :pixel-screen ]
- [ = 3 :mitem ]
- [ make "menu ( filerequest "Load\ File\ \ -\ )
- intuition 6 :pixel-screen
- if emptyp :menu
- [ ]
- [ make "menu openold word :menu ".specs
- repeat 6 [ run freadlist :menu ]
- close :menu ] ] ]
- ( intuition 3 :pixel-window 2 1 0 )
- setpen :pixel-window 0
- ( setpen :pixel-window 0 2 )
- rectfill :pixel-window 0 0 639 399
- make "xmag * :mag 320
- make "ymag * 0.88 :xmag
- make "sx1 -8
- make "sy1 700
- make "sx2 -1
- make "sy2 700 ]
- [ = 3 :menu ]
- [ cond
- [ [ = 1 :mitem ]
- [ recycle
- make "menu openold "Extras\ 1.3:Tools/Palette
- close :menu
- ( intuition 6 :pixel-screen )
- doscommand [ "Extras\ 1.3:Tools/Palette" ] ]
- [ = 2 :mitem ]
- [ if = :sub 1
- [ ( intuition 3 :pixel-window 3 2 1 )
- ( intuition 4 :pixel-window 3 2 2 )
- whenmouse :rdemon ]
- [ ( intuition 3 :pixel-window 3 2 2 )
- ( intuition 4 :pixel-window 3 2 1 )
- whenmouse :tdemon ] ]
- [ = 3 :mitem ]
- [ make "sx1 700
- make "sy1 700 ] ] ] ] ]
- [ ]
- make "menu-list [ ] ]
-
- make "xmag * :mag 320
- make "ymag * 0.88 :xmag
- make "sx1 0
- make "sy1 0
- make "sx2 0
- make "sy2 700
- while [ true ]
- [ while [ or < :sx1 640 < :sx2 640 ]
- [ if >= :sy1 700 [ make "sy1 0 ] [ ]
- if <0 :sx1 [ make "sx1 0 ] [ ]
- while [ < :sx1 640 ]
- [ make "x + :xoff / - :sx1 320 :xmag
- while [ < :sy1 400 ]
- [ make "y + :yoff / - 200 :sy1 :ymag
- setpen :pixel-window color
- ( setpen :pixel-window color 2 )
- rectfill :pixel-window :sx1 :sy1 + :sx1 7 + :sy1 3
- if emptyp :menu-list [ ] :pixel-menus
- make "sy1 + 4 :sy1 ]
- make "sy1 0
- make "sx1 + 8 :sx1 ]
- make "sy1 700
- if >= :sy2 700 [ make "sy2 0 ] [ ]
- if <0 :sx2 [ make "sx2 0 ] [ ]
- while [ and < :sx2 640 >= :sx1 640 ]
- [ make "x + :xoff / - :sx2 320 :xmag
- while [ < :sy2 400 ]
- [ make "y + :yoff / - 200 :sy2 :ymag
- setpen :pixel-window color
- writepixel :pixel-window :sx2 :sy2
- if emptyp :menu-list [ ] :pixel-menus
- make "sy2 + 1 :sy2 ]
- make "sy2 0
- make "sx2 + 1 :sx2 ]
- make "sy2 700 ]
- make "sy1 700
- make "sy2 700
- sleep
- if emptyp :menu-list [ ] :pixel-menus ] ]
-
- make "markrect [
- procedure [ [ :rx :ry :rsize ] [ ] [ :px :py :mx :my ] ]
- make "px + :rx :rsize
- make "mx - :rx :rsize
- make "py + :ry * 0.625 :rsize
- make "my - :ry * 0.625 :rsize
- move :pixel-window :px :py
- draw :pixel-window :mx :py
- draw :pixel-window :mx :my
- draw :pixel-window :px :my
- draw :pixel-window :px :py
- make "px + :px 1
- make "mx - :mx 1
- make "py + :py 1
- make "my - :my 1
- move :pixel-window :px :py
- draw :pixel-window :mx :py
- draw :pixel-window :mx :my
- draw :pixel-window :px :my
- draw :pixel-window :px :py ]
-
- ; *********************************************************************
-
- setmenu @0 se :com-menu [ \ \ Mandelbrot\ \ \
- [ \ z^2+c ]
- [ \ z^2+c\ Epsilon\ Cross ]
- [ \ z^2+c\ Level\ Curve ]
- [ \ z^3+z(c-1)-c ]
- [ \ z^3+z(c-1)-c\ Epsilon\ Cross ]
- [ \ z^3+z(c-1)-c\ Level\ Curve ] ]
-
- make "more-menus [
- procedure [ [ :menu-list ] ]
- if = 2 item 2 :menu-list
- [ ( intuition 3 @0 2 0 0 )
- system 11
- make "menu-list item 3 :menu-list
- cond
- [ [ = :menu-list 1 ] [ mandelbrot ]
- [ = :menu-list 2 ] [ epsilon-cross ]
- [ = :menu-list 3 ] [ level-curve ]
- [ = :menu-list 4 ] [ z^3+z(c-1)-c ]
- [ = :menu-list 5 ] [ z^3-epsilon-cross ]
- [ = :menu-list 6 ] [ z^3-level-curve ] ]
- ( intuition 4 @0 2 0 0 ) ]
- [ ] ]
-
-