/usr/lib/char-canvas.scm is in scheme9 2013.11.26-1.
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 153 154 155 156 157 158 159 160 161 162 163 164 | ; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2010,2012
; Placed in the Public Domain
;
; (canvas-draw canvas integer-X integer-Y char) ==> unspecific
; (canvas-draw-string canvas int-X int-Y string) ==> unspecific
; (canvas-dump canvas) ==> vector
; (canvas-plot canvas integer-X integer-Y char) ==> unspecific
; (canvas-plot-line canvas X Y DX DY char) ==> unspecific
; (make-canvas int-X int-Y int-W int-H) ==> 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=INT-X times y=INT-Y characters. The virtual size of the
; canvas is INT-W (width) times INT-H (height) "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 INTEGER-X/INTEGER-Y.
; 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 limits of the canvas, it will be clipped.
;
; CANVAS-PLOT draws the character CHAR at the virtual position
; INTEGER-X/INTEGER-Y. CANVAS-PLOT-LINE draws a line from the
; virtual position X/Y to DX/DY using the character CHAR. All
; arguments must be integers. 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 "package.scm")
(load-from-library "define-structure.scm")
(load-from-library "setters.scm")
(define-structure canvas x-scale y-scale cmap)
(define make-canvas* make-canvas)
(define canvas-dump canvas-cmap)
(package char-canvas
(:import make-canvas*
canvas-cmap
canvas-x-scale
canvas-y-scale)
(:export canvas-draw
canvas-draw-string
canvas-plot
canvas-plot-line
make-canvas)
(:make-aliases)
(define (canvas-draw 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 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 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 (rat+ x y)
(let ((den (* (cadr x) (cadr y)))
(numx (* (car x) (cadr y)))
(numy (* (car y) (cadr x))))
(ratio (+ numx numy)
den)))
(define (rat>=1/2 x)
(>= (* 2 (car x)) (cadr x)))
(define (canvas-plot-line canvas x0 y0 xn yn c)
(let ((x0 (quotient (* x0 (car (canvas-x-scale canvas)))
(cadr (canvas-x-scale canvas))))
(y0 (quotient (* y0 (car (canvas-y-scale canvas)))
(cadr (canvas-y-scale canvas))))
(xn (quotient (* xn (car (canvas-x-scale canvas)))
(cadr (canvas-x-scale canvas))))
(yn (quotient (* yn (car (canvas-y-scale canvas)))
(cadr (canvas-y-scale canvas))))
(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-draw canvas y x c)
(canvas-draw 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 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)))))
|