Dream 44/Amiga_Dream_44.iso/RiscPc/programmation/scm4e2.arc/!Scm/scm/arc_demos

Text File | 1994-06-19 | 5KB | 218 lines

;
; Scheme demo code for new archi routines - Al Slater 9/6/94->
; Note - if you come up with any really nice routines - I'll include em
; with credits ...
;

;
; Utility functions
;
(define Xscreen 1280)          ;; physical size
(define Yscreen 1024)          ;; ditto
(define Left   -10)
(define Right  10)
(define Top    10)
(define Bottom -10)

(define i->e inexact->exact)  ;; saves typing.

;
; Set-universal-point => given two floating point values plot them.
;
(define (sup xw yw)
      (point
          (i->e (round (/ (* (- xw Left) Xscreen) (- Right Left))))
          (i->e (round (/ (* (- yw Bottom) Yscreen) (- Top Bottom))))
      )
)

; ---------------------------------------------------------------------------
;; martin maps - run by (martin-map) - hit escape when you are bored.
;; note it'll run out of memory eventually if you leave it long enough,
;; but by that time you'll have seen more than enough.


(define a 3.1)                          ;; something around Pi works ok..

(define (martin-iter x y)
(let ((newx (- y (sin x)))(newy (- a x)))
      (begin
      (sup newx newy)
      `(,newx ,newy))))    ;;; note use of backquote...

;
; Prize for doing this more tidily - overwriting your own arguments is
; absolutely bletcherous...(as well as being the most dire example of how not
; to do functional programming)
;
(define (mm x y)
(begin
      (define res (martin-iter x y))
      (set! x (car res))
      (set! y (cadr res))
      (mm x y)
))

(define (martin-map)
(begin
      (mode 12)
      (gcol 0 1)
      ;
      ; ALWAYS define these four somewhere in your gfx routines if using
      ; set-universal-point (and use set! NOT define..) confused yet?
      ;
      (set! Left          -10)
      (set! Right          10)
      (set! Top          10)
      (set! Bottom      -10)
      (mm 0 0)
))

; ---------------------------------------------------------------------------
; A curve or two

(define pi 3.14159)

; degrees -> radians
(define (d->r a)(* a (/ pi 180)))

(define (iterate f from to expr)
(if (> from to)
      'done
      (begin
              (expr f from to)
              (iterate f (+ from 1) to expr))))

(define (p-f f x y)
(let ((fx (f (d->r x))))
      (sup x fx)))

(define (f-curve f)
      (begin
              (mode 12)
              (iterate f Left Right p-f)
              (get)))

(define (trig-curve f)
(begin
      (set! Left          0)
      (set! Right          720)
      (set! Top          2)
      (set! Bottom      -2)
      (f-curve f)
      (get)))

(define (sin-curve)(trig-curve sin))
(define (cos-curve)(trig-curve cos))

(define (tan-curve)
(begin
      (set! Left          0)
      (set! Right          360)
      (set! Top          10)
      (set! Bottom        -10)
      (f-curve tan)
      (get)
))

; ---------------------------------------------------------------------------
; Henon attractor
; try (henon) and hit escape when you've seen enough.

(define h_a 1.4)
(define h_b 0.3)

(define (h_s i) (i->e (+ 400 (* 300 i))))

(define (henon-attractor x y)
(begin
      (point (h_s y)(h_s x))  ;; i prefer it this way around...
      (define xn x)
      (define newx (+ (- y (+ (* h_a x x))) 1))
      (define newy (* h_b xn))
      (henon-attractor newx newy)))

(define (henon)
(begin
      (mode 12)
      (gcol 0 1)
      (henon-attractor 0 0)))

; ---------------------------------------------------------------------------
; Ikeda attractor (from Pickover)
; Horrendously space inefficient no doubt....

(define ia_c1 0.4)
(define ia_c2 0.9)
(define ia_c3 6.0)
(define ia_rho 1.0)
(define ia_scale 200)
(define ia_xoff  600)
(define ia_yoff  500)

(define (ikeda-iter i x y)
(if (> i 3000)
    'done
    (begin
          (define temp (/ (- ia_c1 ia_c3) (+ 1 (* x x) (* y y))))
          (define sin_temp (sin temp))
          (define cos_temp (cos temp))
          (define xt (+ ia_rho (* ia_c2 (- (* x cos_temp) (* y sin_temp)))))
          (define newy (* ia_c2 (+ (* x sin_temp)(* y cos_temp))))
          (define newx xt)
          (point (i->e (+ (* x ia_scale) ia_xoff))
                 (i->e (+ (* y ia_scale) ia_yoff)))
          (ikeda-iter (+ i 1) newx newy))))

(define (ikeda)
(begin
      (mode 12)
      (ikeda-iter 1 0.1 0.1)))

; ---------------------------------------------------------------------------


; ---------------------------------------------------------------------------
; Miscellaneous FP related definitions - see suggested things to try with
; definitions.

;; like a 'for' loop
; try with
; (define (f n w)(+ 1 w))
; (itn 1 10 0 f)
; function 'f' is always defined in terms of 'n' and 'w' generally..

(define (itn n b w f)
    (if (> n b)
        w
        (itn (+ n 1) b (f n w) f)
))

;; itl (like foldl in miranda / itl in KRC)
(define (itl l w f)
    (if (null? l)
        w
        (itl (cdr l) (f (car l) w) f)
    ))

;; lit (like foldr in miranda / lit in KRC (this isn't strictly correct but
;; it'll do.)
(define (lit f w l)
    (if (null? l)
        w
        (f (car l) (lit f w (cdr l)))
    ))

;
; things to try with itl and lit :
; (itl '(1 2 3 4) '() cons)
; (lit cons '() '(1 2 3 4))

; stuff thats nice to have defined..
(define (go)
(begin
      (mode 12)
      (graphics-origin! 640 512)
))

(display "Loaded Arc demos")(newline)