/usr/lib/s9fes/char-canvas.scm is in scheme9 2010.11.13-2.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 | ; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2010
; See the LICENSE file of the S9fES package for terms of use
;
; (canvas-draw canvas integer1 integer2 char) ==> unspecific
; (canvas-draw-string canvas int1 int2 string) ==> unspecific
; (canvas-dump canvas) ==> vector
; (canvas-plot canvas integer1 integer2 char) ==> unspecific
; (canvas-plot-line canvas int1 int2 int3 int4 char) ==> unspecific
; (make-canvas integer1 integer2 integer3 integer4) ==> canvas
;
; (load-from-library "char-canvas.scm")
;
; This is a set of routines for drawing characters and lines on
; a scaled, character-based (a.k.a. "ASCII Art") canvas.
;
; MAKE-CANVAS creates a char canvas with a physical size of
; x=INTEGER1 times y=INTEGER2 characters. The virtual size of
; the canvas is x=INTEGER3 times y=INTEGER4 "pixels". "Real
; coordinates" relate to the physical size of the canvas.
; "Virtual coordinates" are translated to real coordinates by
; scaling. Both types of coordinates are specified in X/Y
; notation. The origin 0/0 is at the lower left corner of the
; canvas. The new canvas will be filled with blanks initially.
;
; CANVAS-DRAW draws character CHAR at position INTEGER1/INTEGER2.
; It uses real coordinates. CANVAS-DRAWSTRING draws a string
; instead of a single character. When the X or Y coordinate is
; outside of the canvas, C will not be drawn. When STRING extends
; beyond the the limits of the canvas, it will be clipped.
;
; CANVAS-PLOT draws the character CHAR at the virtual position
; INTEGER1/INTEGER2. CANVAS-PLOT-LINE draws a line from the
; virtual position INT1/INT2 to INT3/INT4 using the character
; CHAR. Lines originating or extending outside of the canvas
; will be clipped.
;
; CANVAS-DUMP returns a vector of strings that contain the
; characters written to the canvas. The vector indexes are the
; Y-coordinates, the string offsets the X-coordinates.
;
; Example: (let ((c (make-canvas 10 5 10 10)))
; (canvas-plot-line c 0 9 9 0 #\#)
; (canvas-plot-line c 0 0 9 9 #\*)
; (canvas-dump c)) ==> #("## **"
; " ## ** "
; " ** "
; " ** ## "
; "** ##")
(load-from-library "setters.scm")
(load-from-library "define-structure.scm")
(define-structure canvas x-scale y-scale cmap)
(define canvas-dump canvas-cmap)
(define canvas-draw
(let ((canvas-cmap canvas-cmap))
(lambda (canvas x y c)
(let* ((cmap (canvas-cmap canvas))
(k (vector-length cmap)))
(if (and (<= 0 y (- k 1))
(<= 0 x (- (string-length (vector-ref cmap 0)) 1)))
(string-set! (vector-ref cmap (- k y 1)) x c))))))
(define canvas-draw-string
(let ((canvas-cmap canvas-cmap))
(lambda (canvas x y s)
(let* ((ks (string-length s))
(line (vector-ref (canvas-cmap canvas)
(- (vector-length (canvas-cmap canvas))
y
1)))
(kl (string-length line)))
(do ((x x (+ 1 x))
(i 0 (+ 1 i)))
((or (>= i ks)
(>= x kl)))
(string-set! line x (string-ref s i)))))))
(define canvas-plot
(let ((canvas-x-scale canvas-x-scale)
(canvas-y-scale canvas-y-scale))
(lambda (canvas x y c)
(let ((x (quotient (* x (car (canvas-x-scale canvas)))
(cadr (canvas-x-scale canvas))))
(y (quotient (* y (car (canvas-y-scale canvas)))
(cadr (canvas-y-scale canvas)))))
(canvas-draw canvas x y c)))))
(define (ratio x y)
(if (zero? y)
'(0 0)
(let ((g (gcd x y)))
(list (quotient x g) (quotient y g)))))
(define canvas-plot-line
(let ((ratio ratio)
(rat+
(lambda (x y)
(let ((den (* (cadr x) (cadr y)))
(numx (* (car x) (cadr y)))
(numy (* (car y) (cadr x))))
(ratio (+ numx numy)
den))))
(rat>=1/2
(lambda (x)
(>= (* 2 (car x)) (cadr x)))))
(lambda (canvas x0 y0 xn yn c)
(let ((steep (> (abs (- yn y0))
(abs (- xn x0)))))
(if steep
(begin (swap! x0 y0)
(swap! xn yn)))
(if (> x0 xn)
(begin (swap! x0 xn)
(swap! y0 yn)))
(let ((dx (- xn x0))
(dy (abs (- yn y0))))
(let ((de (ratio dy dx))
(ys (if (< y0 yn) 1 -1)))
(let plot ((x x0)
(y y0)
(e '(0 1)))
(if (<= x xn)
(begin (if steep
(canvas-plot canvas y x c)
(canvas-plot canvas x y c))
(let ((e (rat+ e de)))
(if (rat>=1/2 e)
(begin (set! y (+ y ys))
(set! e (rat+ e '(-1 1)))))
(plot (+ 1 x)
y
e)))))))))))
(define make-canvas* make-canvas)
(define make-canvas
(let ((ratio ratio)
(make-canvas* make-canvas*))
(lambda (x-max y-max v-x-max v-y-max)
(let* ((x-scale (ratio x-max v-x-max))
(y-scale (ratio y-max v-y-max)))
(make-canvas* x-scale
y-scale
(let ((v (make-vector y-max)))
(do ((i 0 (+ 1 i)))
((= i y-max))
(vector-set! v i (make-string x-max #\space)))
v))))))
|