577 lines
14 KiB
Bash
577 lines
14 KiB
Bash
#!/bin/sh
|
|
:; exec /usr/local/bin/stk -f "$0" "$@"
|
|
;;;;
|
|
;;;; Copyright © 1994-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;; STkTurtle v1.0
|
|
;;;;
|
|
;;;; Permission to use, copy, modify, distribute,and license this
|
|
;;;; software and its documentation for any purpose is hereby granted,
|
|
;;;; provided that existing copyright notices are retained in all
|
|
;;;; copies and that this notice is included verbatim in any
|
|
;;;; distributions. No written agreement, license, or royalty fee is
|
|
;;;; required for any of the authorized uses.
|
|
;;;; This software is provided ``AS IS'' without express or implied
|
|
;;;; warranty.
|
|
|
|
;;;; A (direct) rewritting of the TkTurtle demo found on the net in STk.
|
|
;;;; Original copyright:
|
|
;;;; Copyright 1993 James Noble, kjx@comp.vuw.ac.nz
|
|
|
|
;;;;
|
|
;;;; Author: Erick Gallesio [eg@unice.fr]
|
|
;;;; Creation date: 1994
|
|
;;;; Last file update: 3-Sep-1999 19:04 (eg)
|
|
|
|
;;;; This file comports two distinct parts.
|
|
;;;; First part is the turtle package
|
|
;;;; Second parts contains a set of examples using the turtle package
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; T u r t l e p a c k a g e
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define turtle-canvas-name ".c")
|
|
(define turtle-canvas '())
|
|
|
|
(define turtle-colours #("" "root_weave" "stipple" "gray1" "boxes"
|
|
"hlines2" "vlines2" "cross_weave"
|
|
"light_gray" "dimple1" "vlines3" "hlines3"
|
|
"grid4" "gray3" "dimple3" "grid8"))
|
|
|
|
(define turtle-num_colours 16)
|
|
|
|
(define turtle-d2r (/ 180 3.14159))
|
|
|
|
(define turtle-x 0)
|
|
(define turtle-y 0)
|
|
(define turtle-direction 270)
|
|
(define turtle-width 0)
|
|
(define turtle-colour 0)
|
|
(define turtle-pen #t)
|
|
|
|
(define turtle-speed #t)
|
|
(define turtle-show #t)
|
|
|
|
|
|
;;;
|
|
;;; initialise turtle
|
|
;;;
|
|
(define (turtle)
|
|
;; clear actually does this, plus draw-turtle
|
|
(set! turtle-x 0)
|
|
(set! turtle-y 0)
|
|
(set! turtle-direction 270)
|
|
(set! turtle-width 0)
|
|
(set! turtle-colour 0)
|
|
(set! turtle-pen #t)
|
|
|
|
;; debugging
|
|
(set! turtle-speed #t)
|
|
(set! turtle-show #t)
|
|
|
|
(if (winfo 'exists turtle-canvas-name)
|
|
(new)
|
|
(begin
|
|
(scrollbar ".v" :relief "sunken" :borderwidth 3
|
|
:command (lambda l (apply turtle-canvas 'yview l)))
|
|
(scrollbar ".h" :relief "sunken" :borderwidth 3
|
|
:orient 'horiz :command (lambda l
|
|
(apply turtle-canvas 'xview l)))
|
|
|
|
(canvas turtle-canvas-name :borderwidth 3
|
|
:scrollregion '(-1000 -1000 1000 1000)
|
|
:xscrollcommand (lambda l (apply .h 'set l))
|
|
:yscrollcommand (lambda l (apply .v 'set l))
|
|
:height 500
|
|
:width 500)
|
|
|
|
(set! turtle-canvas (string->widget turtle-canvas-name))
|
|
|
|
(centre)
|
|
|
|
(pack .h :side "bottom" :fill "x")
|
|
(pack .v :side "right" :fill "y")
|
|
(pack turtle-canvas :expand #t :fill "both")
|
|
|
|
|
|
(bind turtle-canvas "<2>" (lambda (x y)
|
|
(turtle-canvas 'scan 'mark x y)))
|
|
(bind turtle-canvas "<B2-Motion>" (lambda (x y)
|
|
(turtle-canvas 'scan 'dragto x y)))
|
|
(bind turtle-canvas "<c>" centre)
|
|
(bind turtle-canvas "<Control-c>" (lambda () (destroy ".")))
|
|
(bind turtle-canvas "<Control-q>" (lambda () (destroy ".")))
|
|
(bind turtle-canvas "<f>" toggle-speed)
|
|
(bind turtle-canvas "<s>" toggle-show)
|
|
|
|
(focus turtle-canvas)
|
|
|
|
(wm 'minsize "." 10 10)
|
|
(wm 'title "." "Turtle")
|
|
(wm 'iconname "." "Turtle")
|
|
|
|
(draw-turtle))))
|
|
|
|
;;;
|
|
;;; drawing
|
|
;;;
|
|
|
|
(define (make-stipple n)
|
|
(let ((name (vector-ref turtle-colours n)))
|
|
(if (string=? name "")
|
|
""
|
|
(string-append "@" *STk-library* "/Images/" name))))
|
|
|
|
(define (go length)
|
|
(let ((newx (+ turtle-x (* (cos (/ turtle-direction turtle-d2r)) length)))
|
|
(newy (+ turtle-y (* (sin (/ turtle-direction turtle-d2r)) length))))
|
|
|
|
(goto newx newy)
|
|
length))
|
|
|
|
(define (goto x y)
|
|
(when turtle-pen
|
|
(turtle-canvas 'create 'line turtle-x turtle-y x y
|
|
:width turtle-width
|
|
:stipple (make-stipple turtle-colour)
|
|
:tags 'line))
|
|
|
|
(set! turtle-x x)
|
|
(set! turtle-y y)
|
|
(when turtle-show (draw-turtle))
|
|
(when turtle-speed (update))
|
|
(list x y))
|
|
|
|
|
|
;;; writing text
|
|
(define (Write text)
|
|
(turtle-canvas 'create 'text turtle-x turtle-y
|
|
:text text
|
|
:stipple (make-stipple turtle-colour)
|
|
:tags 'text)
|
|
(when turtle-speed (update)))
|
|
|
|
|
|
;;; writing windows
|
|
(define (window name)
|
|
(turtle-canvas 'create 'window turtle-x turtle-y
|
|
:window name
|
|
:tags 'window)
|
|
(update))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;; drawing parameters
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
;; change pen state
|
|
(define (pen . p)
|
|
(if (null? p)
|
|
turtle-pen
|
|
(set! turtle-pen (car p))))
|
|
|
|
(define (down) (pen #t))
|
|
(define (up) (pen #f))
|
|
|
|
|
|
;;; change direction
|
|
(define (turn n)
|
|
(turnto (+ turtle-direction n)))
|
|
|
|
(define (turnto n)
|
|
(set! turtle-direction (modulo (floor n) 360))
|
|
(draw-turtle)
|
|
turtle-direction)
|
|
|
|
(define (east) (turnto 0))
|
|
(define (south) (turnto 90))
|
|
(define (west) (turnto 180))
|
|
(define (north) (turnto 270))
|
|
|
|
(define (direction)
|
|
turtle-direction)
|
|
|
|
(define (location)
|
|
(list turtle-x turtle-y))
|
|
|
|
(define (width . w)
|
|
(unless (null? w)
|
|
(set! turtle-width (car w))
|
|
(draw-turtle))
|
|
turtle-width)
|
|
|
|
(define (colour . c)
|
|
(if (null? c)
|
|
turtle-colour
|
|
(set! turtle-colour (modulo (floor (car c)) turtle-num_colours))))
|
|
|
|
(define (status . c)
|
|
(if (null? c)
|
|
(list turtle-x turtle-y turtle-direction turtle-width turtle-colour
|
|
turtle-pen)
|
|
(if (not (= (length (car c)) 6))
|
|
(error "Can't restore saved state")
|
|
(let ((c (car c)))
|
|
(set! turtle-x (list-ref c 0))
|
|
(set! turtle-y (list-ref c 1))
|
|
(set! turtle-direction (list-ref c 2))
|
|
(set! turtle-width (list-ref c 3))
|
|
(set! turtle-colour (list-ref c 4))
|
|
(set! turtle-pen (list-ref c 5))
|
|
(draw-turtle)
|
|
c))))
|
|
|
|
(define (draw-turtle)
|
|
(when turtle-show
|
|
(turtle-canvas 'delete 'turtle)
|
|
(turtle-canvas 'create 'line
|
|
turtle-x
|
|
turtle-y
|
|
(+ turtle-x (* (cos (/ turtle-direction turtle-d2r)) 10))
|
|
(+ turtle-y (* (sin (/ turtle-direction turtle-d2r)) 10))
|
|
:arrow 'last
|
|
:fill "red"
|
|
:tags 'turtle
|
|
:width turtle-width))
|
|
0)
|
|
|
|
(define (show)
|
|
(set! turtle-show #t)
|
|
(draw-turtle)
|
|
#t)
|
|
|
|
(define (hide)
|
|
(set! turtle-show #f)
|
|
(turtle-canvas 'delete 'turtle)
|
|
#f)
|
|
|
|
(define (toggle-show)
|
|
(if turtle-show (hide) (show)))
|
|
|
|
|
|
;;; misc
|
|
(define (home)
|
|
(set! turtle-x 0)
|
|
(set! turtle-y 0)
|
|
(set! turtle-direction 270)
|
|
(draw-turtle))
|
|
|
|
(define (clear)
|
|
(home)
|
|
(down)
|
|
(width 0)
|
|
(colour 0)
|
|
(turtle-canvas 'delete 'line 'text)
|
|
(draw-turtle))
|
|
|
|
(define (new)
|
|
(clear)
|
|
(turtle-canvas 'delete 'window))
|
|
|
|
(define (screen-dump . file)
|
|
(turtle-canvas 'postscript
|
|
:file (if (null? file) "Screen-dump.ps" (car file))))
|
|
|
|
(define (centre)
|
|
(turtle-canvas 'xview 'moveto 0.37)
|
|
(turtle-canvas 'yview 'moveto 0.37))
|
|
|
|
|
|
;;;conversion
|
|
(define (d2r degrees)
|
|
(/ degrees turtle-d2r))
|
|
|
|
;;; speed
|
|
(define (speed . s)
|
|
(if (null? s)
|
|
turtle-speed
|
|
(set! turtle-speed (car s))))
|
|
|
|
(define (slow) (speed #t))
|
|
(define (fast) (speed #f))
|
|
(define (toggle-speed) (if turtle-speed (fast) (slow)))
|
|
|
|
;;; MACROS - move, moveto
|
|
(define (move distance)
|
|
(let ((oldpen (pen)))
|
|
(go distance)
|
|
(pen oldpen)))
|
|
|
|
(define (moveto x y)
|
|
(let ((oldpen (pen)))
|
|
(goto x y)
|
|
(pen oldpen)))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; E x a m p l e s
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
;; polygon
|
|
(define (polygon n length)
|
|
(do ((k 0 (+ k 1)))
|
|
((= k n))
|
|
(turn (/ 360 n))
|
|
(go length)))
|
|
|
|
;; polygon, with a functional parameter
|
|
(define (fungon n length F)
|
|
(do ((k 0 (+ k 1)))
|
|
((= k n))
|
|
(turn (/ 360 n))
|
|
(F length)))
|
|
|
|
;; Iterative Spiral
|
|
(define (spiral angle length)
|
|
(while (>= length 1)
|
|
(go length)
|
|
(turn angle)
|
|
(set! length (- length 5))))
|
|
|
|
;; Recursive spiral
|
|
(define (rspiral angle length)
|
|
(when (>= length 1)
|
|
(go length)
|
|
(turn angle)
|
|
(rspiral angle (- length 5))))
|
|
|
|
;; "Koch's" a single line - used in snowflake
|
|
(define (koch order length)
|
|
(if (or (<= order 1) (<= length 1))
|
|
(go length)
|
|
(begin
|
|
(koch (- order 1) (/ length 3))
|
|
(turn -60)
|
|
(koch (- order 1) (/ length 3))
|
|
(turn 120)
|
|
(koch (- order 1) (/ length 3))
|
|
(turn -60)
|
|
(koch (- order 1) (/ length 3)))))
|
|
|
|
;; Koch's snowflake fractal
|
|
(define (kochflake order length)
|
|
(do ((k 0 (+ k 1)))
|
|
((= k 3))
|
|
(turn 120)
|
|
(koch order length)))
|
|
|
|
;; tricky version of kochflake
|
|
(define (tricky-kochflake order length)
|
|
(fungon 3 (lambda () (koch order length))))
|
|
|
|
;; Four sided koch
|
|
(define (squarekoch order length)
|
|
(if (or (<= order 1) (<= length 1))
|
|
(go length)
|
|
(begin
|
|
(squarekoch (- order 1) (/ length 3))
|
|
(turn -90)
|
|
(squarekoch (- order 1) (/ length 3))
|
|
(turn 90)
|
|
(squarekoch (- order 1) (/ length 3))
|
|
(turn 90)
|
|
(squarekoch (- order 1) (/ length 3))
|
|
(turn -90)
|
|
(squarekoch (- order 1) (/ length 3)))))
|
|
|
|
(define (squareflake order length)
|
|
(do ((k 0 (+ k 1)))
|
|
((= k 4))
|
|
(turn 90)
|
|
(squarekoch order length)))
|
|
|
|
;; Fractal line
|
|
(define (fracline order angle length)
|
|
(if (< order 1)
|
|
(go length)
|
|
(let* ((ang (- [random (* 2 angle)] angle))
|
|
(len (/ length (* 2 [cos (d2r ang)]))))
|
|
(turn ang)
|
|
(fracline (- order 1) angle len)
|
|
(turn (- (* ang 2)))
|
|
(fracline (- order 1) angle len)
|
|
(turn ang))))
|
|
|
|
;; binary tree
|
|
(define (bintree depth length angle)
|
|
(when (> depth 0)
|
|
(let ((saved (status)))
|
|
(set! depth (- depth 1))
|
|
(go length)
|
|
(turn (- angle))
|
|
(bintree depth length angle)
|
|
(turn (+ angle 2))
|
|
(bintree depth length angle)
|
|
(status saved))))
|
|
|
|
;; C curve fractal
|
|
(define (ccurv order length)
|
|
(if (<= order 1)
|
|
(go length)
|
|
(begin
|
|
(ccurv (- order 1) length)
|
|
(turn 90)
|
|
(ccurv (- order 1) length)
|
|
(turn -90))))
|
|
|
|
;; Dragon curve fractal
|
|
(define (dragon order length)
|
|
(letrec ((dragon-aux (lambda (order length dirn)
|
|
(if (<= order 1)
|
|
(go length)
|
|
(begin
|
|
(dragon-aux (- order 1) length 90)
|
|
(turn dirn)
|
|
(dragon-aux (- order 1) length -90))))))
|
|
(dragon-aux order length 90)))
|
|
|
|
;; Sierpinski's gasket
|
|
(define (gasket order length)
|
|
(when (> order 0)
|
|
(do ((k 0 (+ k 1)))
|
|
((= k 3))
|
|
(gasket (- order 1) (/ length 2))
|
|
(go length)
|
|
(turn 120))))
|
|
|
|
;; Sierpinski's carpet
|
|
(define (carpet order length)
|
|
(if (< order 1)
|
|
(go length)
|
|
(begin
|
|
(carpet (- order 1) (/ length 3))
|
|
(turn -90)
|
|
(carpet (- order 1) (/ length 3))
|
|
(turn 90)
|
|
(carpet (- order 1) (/ length 3))
|
|
(turn 90)
|
|
(carpet (- order 1) (/ length 3))
|
|
(let ((saved (status)))
|
|
(carpet (- order 1) (/ length 3))
|
|
(turn 90)
|
|
(carpet (- order 1) (/ length 3))
|
|
(turn 90)
|
|
(carpet (- order 1) (/ length 3))
|
|
(status saved)
|
|
(turn -90)
|
|
(carpet (- order 1) (/ length 3))))))
|
|
|
|
;; "Bendy" - simple fractal (C curve variation)
|
|
(define (bendy order length)
|
|
(if (< order 1)
|
|
(go length)
|
|
(begin
|
|
(turn 30)
|
|
(bendy (- order 1) (/ length 2))
|
|
(turn -60)
|
|
(bendy (- order 1) (/ length 2))
|
|
(turn 30))))
|
|
|
|
;; "Squigly" - simple fractal (C curve variation)
|
|
(define (squigly order length)
|
|
(if (< order 1)
|
|
(go length)
|
|
(begin
|
|
(turn 30)
|
|
(squigly (- order 1) (/ length 4))
|
|
(turn -60)
|
|
(squigly (- order 1) (/ length 2))
|
|
(turn 60)
|
|
(squigly (- order 1) (/ length 4))
|
|
(turn -30))))
|
|
|
|
(define (randtree depth length angle branch)
|
|
(when (>= depth 1)
|
|
(let ((saved (status))
|
|
(thisbranch (random branch)))
|
|
(set! depth (- depth 1))
|
|
(go (+ (random length) length))
|
|
(turn (- (/ (* angle thisbranch) 4)))
|
|
(do ((k 0 (+ k 1)))
|
|
((= k thisbranch))
|
|
(turn (random angle))
|
|
(randtree depth length angle branch))
|
|
(status saved))))
|
|
|
|
;;windows-demo
|
|
(define (windows-demo)
|
|
(let ((S (scale (& turtle-canvas "scale"))))
|
|
(show)
|
|
(up)
|
|
(goto -200 -200)
|
|
(window S)
|
|
(goto -150 -200)
|
|
(window (button (& turtle-canvas ".spiral-button") :text "Spiral"
|
|
:command (lambda () (spiral [S 'get] 100))))
|
|
(goto -100 -200)
|
|
(window [button (& turtle-canvas ".clear-button") :text "Clear" :command clear])
|
|
(goto -50 -200)
|
|
(window [button (& turtle-canvas ".home-button") :text "Home" :command home])
|
|
(goto 180 -200)
|
|
(window [button (& turtle-canvas ".quit-button") :text "Quit Demo"
|
|
:fg "CadetBlue" :command (lambda () (exit))])
|
|
(S 'set 45)
|
|
(down)
|
|
(home)))
|
|
|
|
(define (item message demo)
|
|
(clear)
|
|
(up)
|
|
(goto 0 220)
|
|
(down)
|
|
(Write message)
|
|
(home)
|
|
(demo))
|
|
|
|
(define (run-demo)
|
|
(item "Polygon"
|
|
(lambda ()
|
|
(do ((k 3 (+ k 1))) ((= k 12))
|
|
(home) (polygon k 50))))
|
|
(item "Lines"
|
|
(lambda ()
|
|
(do ((k 0 (+ k 1))) ((= k 16))
|
|
(moveto 0 0) (turn 22.5) (width k) (go 200))))
|
|
|
|
(item "Stipple"
|
|
(lambda ()
|
|
(width 15)
|
|
(do ((k 0 (+ k 1))) ((= k 16))
|
|
(moveto 0 0) (turn 22.5) (colour k) (go 200))))
|
|
|
|
(item "Fractal lines"
|
|
(lambda ()
|
|
(do ((k 0 (+ k 1))) ((= k 7))
|
|
(home) (fracline 6 40 200))))
|
|
|
|
(item "Spiral" (lambda () (spiral 50 100)))
|
|
(item "Recursive spiral" (lambda () (rspiral 89 100)))
|
|
(item "Recursive spiral" (lambda () (rspiral -90 100)))
|
|
(item "Koch flake" (lambda () (kochflake 3 150)))
|
|
(item "Square flake" (lambda () (squareflake 3 150)))
|
|
(item "Squigly" (lambda () (squigly 4 200)))
|
|
(item "C curve" (lambda () (ccurv 6 20)))
|
|
(item "Dragon" (lambda () (dragon 6 20)))
|
|
(item "Gasket" (lambda () (gasket 6 200)))
|
|
(item "Carpet" (lambda () (carpet 3 250)))
|
|
(item "Binary tree" (lambda () (bintree 6 30 20)))
|
|
(item "Random tree" (lambda () (randtree 4 20 30 6)))
|
|
(item "Windows Demo" windows-demo))
|
|
|
|
|
|
|
|
;; Init part - Run the demo
|
|
(expand-heap 50000)
|
|
(set! *gc-verbose* #f)
|
|
|
|
(turtle)
|
|
(hide)
|
|
|
|
(run-demo)
|