|
| 1 | +;;; LISPKIT DRAW TURTLE |
| 2 | +;;; |
| 3 | +;;; This is a simple library implementing turtle graphics. A new turtle plane gets created |
| 4 | +;;; by invoking `make-turtle`. `make-turtle` sets the origin of the plane as well as a scaling |
| 5 | +;;; factor. A range of functions for modifying the state of a turtle plane is provided: |
| 6 | +;;; |
| 7 | +;;; - `(pen-up turtle)`: Lifts the turtle from the plane |
| 8 | +;;; - `(pen-down turtle)`: Drops the turtle onto the plane |
| 9 | +;;; - `(pen-color color turtle)`: Sets the current color of the turtle |
| 10 | +;;; - `(pen-size size turtle)`: Sets the size of the turtle pen |
| 11 | +;;; - `(home)`: Moves the turtle back to the origin |
| 12 | +;;; - `(move x y turtle)`: Moves the turtle to position `(x, y)` |
| 13 | +;;; - `(heading angle turtle)`: Sets the angle of the turtle (in radians) |
| 14 | +;;; - `(turn angle turtle)`: Turns the turtle by the given angle (in radians) |
| 15 | +;;; - `(left angle turtle)`: Turn left by the given angle (in radians) |
| 16 | +;;; - `(right angle turtle)`: Turn right by the given angle (in radians) |
| 17 | +;;; - `(forward length turtle)`: Moves forward by `length` units drawing a line if the |
| 18 | +;;; pen is down |
| 19 | +;;; - `(backward length turtle)`: Moves backward by `length` units drawing a line if the |
| 20 | +;;; pen is down |
| 21 | +;;; |
| 22 | +;;; Author: Matthias Zenger |
| 23 | +;;; Copyright © 2018 Matthias Zenger. All rights reserved. |
| 24 | +;;; |
| 25 | +;;; Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file |
| 26 | +;;; except in compliance with the License. You may obtain a copy of the License at |
| 27 | +;;; |
| 28 | +;;; http://www.apache.org/licenses/LICENSE-2.0 |
| 29 | +;;; |
| 30 | +;;; Unless required by applicable law or agreed to in writing, software distributed under the |
| 31 | +;;; License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, |
| 32 | +;;; either express or implied. See the License for the specific language governing permissions |
| 33 | +;;; and limitations under the License. |
| 34 | + |
| 35 | +(define-library (lispkit draw turtle) |
| 36 | + |
| 37 | + (export turtle? |
| 38 | + make-turtle |
| 39 | + turtle-drawing |
| 40 | + pen-up |
| 41 | + pen-down |
| 42 | + pen-color |
| 43 | + pen-size |
| 44 | + home |
| 45 | + move |
| 46 | + heading |
| 47 | + turn |
| 48 | + left |
| 49 | + right |
| 50 | + forward |
| 51 | + backward) |
| 52 | + |
| 53 | + (import (lispkit base) |
| 54 | + (lispkit draw)) |
| 55 | + |
| 56 | + (begin |
| 57 | + |
| 58 | + (define-record-type turtle |
| 59 | + (new-turtle drawing x y angle down) |
| 60 | + turtle? |
| 61 | + (drawing turtle-drawing) |
| 62 | + (x turtle-x set-turtle-x!) |
| 63 | + (y turtle-y set-turtle-y!) |
| 64 | + (angle turtle-angle set-turtle-angle!) |
| 65 | + (down turtle-pen-down? set-turtle-pen-down!)) |
| 66 | + |
| 67 | + (define (make-turtle x y sc) |
| 68 | + (let ((drawing (make-drawing))) |
| 69 | + (enable-transformation (scale sc sc (translate x y)) drawing) |
| 70 | + (new-turtle drawing 0.0 0.0 0.0 #t))) |
| 71 | + |
| 72 | + (define (pen-up plane) |
| 73 | + (set-turtle-pen-down! plane #f)) |
| 74 | + |
| 75 | + (define (pen-down plane) |
| 76 | + (set-turtle-pen-down! plane #t)) |
| 77 | + |
| 78 | + (define (pen-color color plane) |
| 79 | + (set-color color (turtle-drawing plane))) |
| 80 | + |
| 81 | + (define (pen-size size plane) |
| 82 | + (set-line-width size (turtle-drawing plane))) |
| 83 | + |
| 84 | + (define (home plane) |
| 85 | + (move 0.0 0.0 plane)) |
| 86 | + |
| 87 | + (define (move x y plane) |
| 88 | + (set-turtle-x! plane x) |
| 89 | + (set-turtle-y! plane y)) |
| 90 | + |
| 91 | + (define (heading angle plane) |
| 92 | + (set-turtle-angle! plane (radian angle))) |
| 93 | + |
| 94 | + (define (turn angle plane) |
| 95 | + (set-turtle-angle! plane (+ (radian angle) (turtle-angle plane)))) |
| 96 | + |
| 97 | + (define (left angle plane) |
| 98 | + (turn (- angle) plane)) |
| 99 | + |
| 100 | + (define (right angle plane) |
| 101 | + (turn angle plane)) |
| 102 | + |
| 103 | + (define (forward len plane) |
| 104 | + (let* ((angle (turtle-angle plane)) |
| 105 | + (ox (turtle-x plane)) |
| 106 | + (oy (turtle-y plane)) |
| 107 | + (x (+ ox (* (cos angle) len))) |
| 108 | + (y (+ oy (* (sin angle) len)))) |
| 109 | + (if (turtle-pen-down? plane) |
| 110 | + (draw-line (point ox oy) (point x y) (turtle-drawing plane))) |
| 111 | + (move x y plane))) |
| 112 | + |
| 113 | + (define (backward len plane) |
| 114 | + (forward (- len) plane)) |
| 115 | + |
| 116 | + (define (radian angle) |
| 117 | + (inexact (/ (* angle pi) 180.0))) |
| 118 | + ) |
| 119 | +) |
| 120 | + |
0 commit comments