/examples/random-art/source.scm

  1
  2;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3
  4(random-source-randomize! default-random-source)
  5
  6;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  7
  8(define (vector-ref-random v)
  9  (vector-ref v (random-integer (vector-length v))))
 10
 11;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 12
 13(define (sin-pi* c) (sin (* pi c)))
 14(define (cos-pi* c) (cos (* pi c)))
 15
 16;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 17
 18(define (random-product-procedure n)
 19
 20  (display "(* ")
 21
 22  (let ((proc-1 (random-procedure (- n 1)))
 23        (proc-2 (random-procedure (- n 1))))
 24
 25    (display ")")
 26
 27    (lambda (a b)
 28
 29      (* (proc-1 a b)
 30         (proc-2 a b)))))
 31
 32;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 33
 34(define (random-average-procedure n)
 35
 36  (display "(avg ")
 37
 38  (let ((proc-1 (random-procedure (- n 1)))
 39        (proc-2 (random-procedure (- n 1))))
 40
 41    (display ")")
 42
 43    (lambda (a b)
 44
 45      (/ (+ (proc-1 a b)
 46            (proc-2 a b))
 47         2.0))))
 48
 49;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 50
 51(define (random-sin-pi*-procedure n)
 52
 53  (display "(sin (* pi ")
 54
 55  (let ((proc (random-procedure (- n 1))))
 56
 57    (display "))")
 58             
 59    (lambda (a b)
 60
 61      (sin-pi* (proc a b)))))
 62
 63;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 64
 65(define (random-cos-pi*-procedure n)
 66
 67  (display "(cos (* pi ")
 68
 69  (let ((proc (random-procedure (- n 1))))
 70
 71    (display "))")
 72             
 73    (lambda (a b)
 74
 75      (cos-pi* (proc a b)))))
 76
 77;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 78
 79(define (random-x-y-procedure n)
 80  (let ((arg (random-integer 2)))
 81    (display (if (= arg 0) "x " "y "))
 82    (lambda (a b)
 83      (vector-ref (vector a b) arg))))
 84
 85;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 86
 87(define (random-procedure n)
 88
 89  (cond ((= n 1)
 90         (random-x-y-procedure #f))
 91
 92        (else
 93         (let ((procedure (vector-ref-random (vector random-product-procedure
 94                                                     random-average-procedure
 95                                                     random-sin-pi*-procedure
 96                                                     random-cos-pi*-procedure))))
 97           (procedure n)))))
 98
 99;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
100
101(display "(lambda (x y) ")
102
103(define fun (random-procedure 7))
104
105(display ")\n")
106
107;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
108
109(glutInit (vector 0) (vector ""))
110
111(glutInitWindowPosition 100 100)
112
113(glutInitWindowSize 500 500)
114
115(glutCreateWindow "Random Art")
116
117(glutReshapeFunc (ortho-2d -1.0 1.0 -1.0 1.0))
118
119;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
120
121(glutDisplayFunc
122 
123 (lambda ()
124
125   (glMatrixMode GL_MODELVIEW)
126
127   (glLoadIdentity)
128
129   (glClearColor 0.0 0.0 0.0 0.0)
130
131   (glClear GL_COLOR_BUFFER_BIT)
132
133   (glBegin GL_POINTS)
134
135   (do ((y -1.0 (+ y 0.01)))
136       ((> y 1.0))
137     
138     (do ((x -1.0 (+ x 0.01)))
139         ((> x 1.0))
140
141       (let ((val (fun x y)))
142
143         (let ((grey (/ (+ val 1.0) 2.0)))
144
145           (glColor4d grey grey grey 1.0)
146
147           (glVertex2d x y)))))
148
149   (glEnd)
150
151   (glFlush)
152
153   ))
154
155;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
156
157(glutKeyboardFunc
158 (lambda (key x y)
159   (exit)))
160
161;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
162
163(glutMainLoop)