Data commit
This commit is contained in:
Ingy döt Net
parent
7387c8f97b
commit
cb5bb5e222
199093 changed files with 3378972 additions and 0 deletions
41
Task/Mandelbrot-set/Scheme/mandelbrot-set-1.ss
Normal file
41
Task/Mandelbrot-set/Scheme/mandelbrot-set-1.ss
Normal file
|
|
@ -0,0 +1,41 @@
|
|||
(define x-centre -0.5)
|
||||
(define y-centre 0.0)
|
||||
(define width 4.0)
|
||||
(define i-max 800)
|
||||
(define j-max 600)
|
||||
(define n 100)
|
||||
(define r-max 2.0)
|
||||
(define file "out.pgm")
|
||||
(define colour-max 255)
|
||||
(define pixel-size (/ width i-max))
|
||||
(define x-offset (- x-centre (* 0.5 pixel-size (+ i-max 1))))
|
||||
(define y-offset (+ y-centre (* 0.5 pixel-size (+ j-max 1))))
|
||||
|
||||
(define (inside? z)
|
||||
(define (*inside? z-0 z n)
|
||||
(and (< (magnitude z) r-max)
|
||||
(or (= n 0)
|
||||
(*inside? z-0 (+ (* z z) z-0) (- n 1)))))
|
||||
(*inside? z 0 n))
|
||||
|
||||
(define (boolean->integer b)
|
||||
(if b colour-max 0))
|
||||
|
||||
(define (pixel i j)
|
||||
(boolean->integer
|
||||
(inside?
|
||||
(make-rectangular (+ x-offset (* pixel-size i))
|
||||
(- y-offset (* pixel-size j))))))
|
||||
|
||||
(define (plot)
|
||||
(with-output-to-file file
|
||||
(lambda ()
|
||||
(begin (display "P2") (newline)
|
||||
(display i-max) (newline)
|
||||
(display j-max) (newline)
|
||||
(display colour-max) (newline)
|
||||
(do ((j 1 (+ j 1))) ((> j j-max))
|
||||
(do ((i 1 (+ i 1))) ((> i i-max))
|
||||
(begin (display (pixel i j)) (newline))))))))
|
||||
|
||||
(plot)
|
||||
300
Task/Mandelbrot-set/Scheme/mandelbrot-set-2.ss
Normal file
300
Task/Mandelbrot-set/Scheme/mandelbrot-set-2.ss
Normal file
|
|
@ -0,0 +1,300 @@
|
|||
;; A program written for CHICKEN Scheme version 5.3.0 and various
|
||||
;; eggs.
|
||||
|
||||
(import (r7rs))
|
||||
(import (scheme base))
|
||||
(import (scheme case-lambda))
|
||||
(import (scheme inexact))
|
||||
|
||||
(import (prefix sdl2 "sdl2:"))
|
||||
(import (prefix imlib2 "imlib2:"))
|
||||
|
||||
(import (format))
|
||||
(import (matchable))
|
||||
(import (simple-exceptions))
|
||||
|
||||
(define sdl2-subsystems-used '(events video))
|
||||
|
||||
;; ------------------------------
|
||||
;; Basics for using the sdl2 egg:
|
||||
(sdl2:set-main-ready!)
|
||||
(sdl2:init! sdl2-subsystems-used)
|
||||
(on-exit sdl2:quit!)
|
||||
(current-exception-handler
|
||||
(let ((original-handler (current-exception-handler)))
|
||||
(lambda (exception)
|
||||
(sdl2:quit!)
|
||||
(original-handler exception))))
|
||||
;; ------------------------------
|
||||
|
||||
(define-record-type <mandel-params>
|
||||
(%%make-mandel-params)
|
||||
mandel-params?
|
||||
(window ref-window set-window!)
|
||||
(xcenter ref-xcenter set-xcenter!)
|
||||
(ycenter ref-ycenter set-ycenter!)
|
||||
(pixels-per-unit ref-pixels-per-unit set-pixels-per-unit!)
|
||||
(pixels-per-event-check ref-pixels-per-event-check
|
||||
set-pixels-per-event-check!)
|
||||
(max-escape-time ref-max-escape-time set-max-escape-time!))
|
||||
|
||||
(define initial-width 400)
|
||||
(define initial-height 400)
|
||||
(define initial-xcenter -3/4)
|
||||
(define initial-ycenter 0)
|
||||
(define initial-pixels-per-unit 150)
|
||||
(define initial-pixels-per-event-check 1000)
|
||||
(define initial-max-escape-time 1000)
|
||||
|
||||
(define (make-mandel-params window)
|
||||
(let ((params (%%make-mandel-params)))
|
||||
(set-window! params window)
|
||||
(set-xcenter! params initial-xcenter)
|
||||
(set-ycenter! params initial-ycenter)
|
||||
(set-pixels-per-unit! params initial-pixels-per-unit)
|
||||
(set-pixels-per-event-check! params
|
||||
initial-pixels-per-event-check)
|
||||
(set-max-escape-time! params initial-max-escape-time)
|
||||
params))
|
||||
|
||||
(define window (sdl2:create-window! "mandelbrot set task"
|
||||
'centered 'centered
|
||||
initial-width initial-height
|
||||
'()))
|
||||
(define params (make-mandel-params window))
|
||||
|
||||
(define empty-color (sdl2:make-color 200 200 200))
|
||||
|
||||
(define (clear-mandel!)
|
||||
(sdl2:fill-rect! (sdl2:window-surface (ref-window params))
|
||||
#f empty-color)
|
||||
(sdl2:update-window-surface! window))
|
||||
|
||||
(define drawing? #t)
|
||||
(define redraw? #f)
|
||||
|
||||
(define (draw-mandel! event-checker)
|
||||
(clear-mandel!)
|
||||
(let repeat ()
|
||||
(let*-values
|
||||
(((window) (ref-window params))
|
||||
((width height) (sdl2:window-size window)))
|
||||
(let* ((xcenter (ref-xcenter params))
|
||||
(ycenter (ref-ycenter params))
|
||||
(pixels-per-unit (ref-pixels-per-unit params))
|
||||
(pixels-per-event-check
|
||||
(ref-pixels-per-event-check params))
|
||||
(max-escape-time (ref-max-escape-time params))
|
||||
(step (/ 1.0 pixels-per-unit))
|
||||
(xleft (- xcenter (/ width (* 2.0 pixels-per-unit))))
|
||||
(ytop (+ ycenter (/ height (* 2.0 pixels-per-unit))))
|
||||
(pixel-count 0))
|
||||
(do ((j 0 (+ j 1))
|
||||
(cy ytop (- cy step)))
|
||||
((= j height))
|
||||
(do ((i 0 (+ i 1))
|
||||
(cx xleft (+ cx step)))
|
||||
((= i width))
|
||||
(let* ((color (compute-color-by-escape-time-algorithm
|
||||
cx cy max-escape-time)))
|
||||
(sdl2:surface-set! (sdl2:window-surface window)
|
||||
i j color)
|
||||
(if (= pixel-count pixels-per-event-check)
|
||||
(let ((event-checker (call/cc event-checker)))
|
||||
(cond (redraw?
|
||||
(set! redraw? #f)
|
||||
(clear-mandel!)
|
||||
(repeat)))
|
||||
(set! pixel-count 0))
|
||||
(set! pixel-count (+ pixel-count 1)))))
|
||||
;; Display a row.
|
||||
(sdl2:update-window-surface! window))))
|
||||
(set! drawing? #f)
|
||||
(repeat)))
|
||||
|
||||
(define (compute-color-by-escape-time-algorithm
|
||||
cx cy max-escape-time)
|
||||
(escape-time->color (compute-escape-time cx cy max-escape-time)
|
||||
max-escape-time))
|
||||
|
||||
(define (compute-escape-time cx cy max-escape-time)
|
||||
(let loop ((x 0.0)
|
||||
(y 0.0)
|
||||
(iter 0))
|
||||
(if (= iter max-escape-time)
|
||||
iter
|
||||
(let ((xsquared (* x x))
|
||||
(ysquared (* y y)))
|
||||
(if (< 4 (+ xsquared ysquared))
|
||||
iter
|
||||
(let ((x (+ cx (- xsquared ysquared)))
|
||||
(y (+ cy (* (+ x x) y))))
|
||||
(loop x y (+ iter 1))))))))
|
||||
|
||||
(define (escape-time->color escape-time max-escape-time)
|
||||
;; This is a very naive and ad hoc algorithm for choosing colors,
|
||||
;; but hopefully will suffice for the task. With this algorithm, at
|
||||
;; least one can zoom in and see some of the fractal-like structures
|
||||
;; out on the filaments.
|
||||
(let* ((initial-ppu initial-pixels-per-unit)
|
||||
(ppu (ref-pixels-per-unit params))
|
||||
(fraction (* (/ (log escape-time) (log max-escape-time))))
|
||||
(fraction (if (= fraction 1.0)
|
||||
fraction
|
||||
(* fraction
|
||||
(/ (log initial-ppu)
|
||||
(log (max initial-ppu (* 0.05 ppu)))))))
|
||||
(value (- 255 (min 255 (exact-rounded (* fraction 255))))))
|
||||
(sdl2:make-color value value value)))
|
||||
|
||||
(define (exact-rounded x)
|
||||
(exact (round x)))
|
||||
|
||||
(define (event-loop)
|
||||
(define event (sdl2:make-event))
|
||||
(define painter draw-mandel!)
|
||||
(define zoom-ratio 2)
|
||||
|
||||
(define (recenter! xcoord ycoord)
|
||||
(let*-values
|
||||
(((window) (ref-window params))
|
||||
((width height) (sdl2:window-size window))
|
||||
((ppu) (ref-pixels-per-unit params)))
|
||||
(set-xcenter! params
|
||||
(+ (ref-xcenter params)
|
||||
(/ (- (* 2.0 xcoord) width) (* 2.0 ppu))))
|
||||
(set-ycenter! params
|
||||
(+ (ref-ycenter params)
|
||||
(/ (- height (* 2.0 ycoord)) (* 2.0 ppu))))))
|
||||
|
||||
(define (zoom-in!)
|
||||
(let* ((ppu (ref-pixels-per-unit params))
|
||||
(ppu (* ppu zoom-ratio)))
|
||||
(set-pixels-per-unit! params ppu)))
|
||||
|
||||
(define (zoom-out!)
|
||||
(let* ((ppu (ref-pixels-per-unit params))
|
||||
(ppu (* (/ 1.0 zoom-ratio) ppu)))
|
||||
(set-pixels-per-unit! params (max 1 ppu))))
|
||||
|
||||
(define (restore-original-settings!)
|
||||
(set-xcenter! params initial-xcenter)
|
||||
(set-ycenter! params initial-ycenter)
|
||||
(set-pixels-per-unit! params initial-pixels-per-unit)
|
||||
(set-pixels-per-event-check!
|
||||
params initial-pixels-per-event-check)
|
||||
(set-max-escape-time! params initial-max-escape-time)
|
||||
(set! zoom-ratio 2))
|
||||
|
||||
(define dump-image! ; Really this should put up a dialog.
|
||||
(let ((dump-number 1))
|
||||
(lambda ()
|
||||
(let*-values
|
||||
(((window) (ref-window params))
|
||||
((width height) (sdl2:window-size window))
|
||||
((surface) (sdl2:window-surface window)))
|
||||
(let ((filename (string-append "mandelbrot-image-"
|
||||
(number->string dump-number)
|
||||
".png"))
|
||||
(img (imlib2:image-create width height)))
|
||||
(do ((j 0 (+ j 1)))
|
||||
((= j height))
|
||||
(do ((i 0 (+ i 1)))
|
||||
((= i width))
|
||||
(let-values
|
||||
(((r g b a) (sdl2:color->values
|
||||
(sdl2:surface-ref surface i j))))
|
||||
(imlib2:image-draw-pixel
|
||||
img (imlib2:color/rgba r g b a) i j))))
|
||||
(imlib2:image-alpha-set! img #f)
|
||||
(imlib2:image-save img filename)
|
||||
(format #t "~a written~%" filename)
|
||||
(set! dump-number (+ dump-number 1)))))))
|
||||
|
||||
(let loop ()
|
||||
(when redraw?
|
||||
(set! drawing? #t))
|
||||
(when drawing?
|
||||
(set! painter (call/cc painter)))
|
||||
(set! redraw? #f)
|
||||
(if (not (sdl2:poll-event! event))
|
||||
(loop)
|
||||
(begin
|
||||
(match (sdl2:event-type event)
|
||||
('quit) ; Quit by leaving the loop.
|
||||
('window
|
||||
(match (sdl2:window-event-event event)
|
||||
;; It should be possible to resize the window, but I
|
||||
;; have not yet figured out how to do this with SDL2
|
||||
;; and not crash sometimes.
|
||||
((or 'exposed 'restored)
|
||||
(sdl2:update-window-surface! (ref-window params))
|
||||
(loop))
|
||||
(_ (loop))))
|
||||
('mouse-button-down
|
||||
(recenter! (sdl2:mouse-button-event-x event)
|
||||
(sdl2:mouse-button-event-y event))
|
||||
(set! redraw? #t)
|
||||
(loop))
|
||||
('key-down
|
||||
(match (sdl2:keyboard-event-sym event)
|
||||
('q 'quit-by-leaving-the-loop)
|
||||
((or 'plus 'kp-plus)
|
||||
(zoom-in!)
|
||||
(set! redraw? #t)
|
||||
(loop))
|
||||
((or 'minus 'kp-minus)
|
||||
(zoom-out!)
|
||||
(set! redraw? #t)
|
||||
(loop))
|
||||
((or 'n-2 'kp-2)
|
||||
(set! zoom-ratio 2)
|
||||
(loop))
|
||||
((or 'n-3 'kp-3)
|
||||
(set! zoom-ratio 3)
|
||||
(loop))
|
||||
((or 'n-4 'kp-4)
|
||||
(set! zoom-ratio 4)
|
||||
(loop))
|
||||
((or 'n-5 'kp-5)
|
||||
(set! zoom-ratio 5)
|
||||
(loop))
|
||||
((or 'n-6 'kp-6)
|
||||
(set! zoom-ratio 6)
|
||||
(loop))
|
||||
((or 'n-7 'kp-7)
|
||||
(set! zoom-ratio 7)
|
||||
(loop))
|
||||
((or 'n-8 'kp-8)
|
||||
(set! zoom-ratio 8)
|
||||
(loop))
|
||||
((or 'n-9 'kp-9)
|
||||
(set! zoom-ratio 9)
|
||||
(loop))
|
||||
('o
|
||||
(restore-original-settings!)
|
||||
(set! redraw? #t)
|
||||
(loop))
|
||||
('p
|
||||
(dump-image!)
|
||||
(loop))
|
||||
(some-key-in-which-we-are-not-interested
|
||||
(loop))))
|
||||
(some-event-in-which-we-are-not-interested
|
||||
(loop)))))))
|
||||
|
||||
;; At the least this legend should go in a window, but printing it to
|
||||
;; the terminal will, hopefully, suffice for the task.
|
||||
(format #t "~%~8tACTIONS~%")
|
||||
(format #t "~8t-------~%")
|
||||
(define fmt "~2t~a~15t: ~a~%")
|
||||
(format #t fmt "Q key" "quit")
|
||||
(format #t fmt "mouse button" "recenter")
|
||||
(format #t fmt "+ key" "zoom in")
|
||||
(format #t fmt "- key" "zoom in")
|
||||
(format #t fmt "2 .. 9 key" "set zoom ratio")
|
||||
(format #t fmt "O key" "restore original")
|
||||
(format #t fmt "P key" "dump to a PNG")
|
||||
(format #t "~%")
|
||||
|
||||
(event-loop)
|
||||
Loading…
Add table
Add a link
Reference in a new issue