diff options
author | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:29 -0800 |
---|---|---|
committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:29 -0800 |
commit | 8466d8cfa486fb30d1755c4261b781135083787b (patch) | |
tree | c8c12c67246f543c3cc4f64d1c07e003cb1d45ae /tek40.scm | |
parent | 87b82b5822ca54228cfa6df29be3ad9d4bc47d16 (diff) | |
download | slib-8466d8cfa486fb30d1755c4261b781135083787b.tar.gz slib-8466d8cfa486fb30d1755c4261b781135083787b.zip |
Import Upstream version 3a1upstream/3a1
Diffstat (limited to 'tek40.scm')
-rw-r--r-- | tek40.scm | 92 |
1 files changed, 0 insertions, 92 deletions
diff --git a/tek40.scm b/tek40.scm deleted file mode 100644 index b2be1ca..0000000 --- a/tek40.scm +++ /dev/null @@ -1,92 +0,0 @@ -;"tek40.scm", Tektronix 4000 series graphics support in Scheme. -;Copyright (C) 1992, 1994 Aubrey Jaffer -; -;Permission to copy this software, to modify it, to redistribute it, -;to distribute modified versions, and to use it for any purpose is -;granted, subject to the following restrictions and understandings. -; -;1. Any copy made of this software must include this copyright notice -;in full. -; -;2. I have made no warrantee or representation that the operation of -;this software will be error-free, and I am under no obligation to -;provide any services, by way of maintenance, update, or otherwise. -; -;3. In conjunction with products arising from the use of this -;material, there shall be no use of my name in any advertising, -;promotional, or sales literature without prior written consent in -;each case. - -;THIS FILE NEEDS MORE WORK. - -;The Tektronix 4000 series graphics protocol gives the user a 1024 by -;1024 square drawing area. The origin is in the lower left corner of -;the screen. Increasing y is up and increasing x is to the right. - -;The graphics control codes are sent over the current-output-port and -;can be mixed with regular text and ANSI or other terminal control -;sequences. - -; (tek40:init) procedure - -(define (tek40:init) 'noop) - -(define esc-string (string (integer->char #o33))) - -(define tek40:graphics-str - (string-append - (string slib:form-feed) - esc-string (string (integer->char #o14)) - ;; clear the screen - )) - -(define (tek40:graphics) (display tek40:graphics-str) (force-output)) - -(define (tek40:text) - (tek40:move 0 12) - (write-char (integer->char #o37))) - -(define (tek40:linetype linetype) - (cond ((or (negative? linetype) (> linetype 15)) - (slib:error "bad linetype" linetype)) - (else - (display esc-string) - (write-char (integer->char (+ (char->integer #\`) linetype)))))) - -(define (tek40:move x y) - (write-char (integer->char #o35)) - (tek40:draw x y)) - -(define (tek40:draw x y) - (display (string - (integer->char (+ #x20 (quotient y 32))) - (integer->char (+ #x60 (remainder y 32))) - (integer->char (+ #x20 (quotient x 32))) - (integer->char (+ #x40 (remainder x 32)))))) - -(define (tek40:put-text x y str) - (tek40:move x (+ y -11)) - (write-char (integer->char #o37)) - (display str)) - -(define (tek40:reset) (display tek40:graphics-str) (force-output)) - -(define (tek40:test) - (tek40:init) -; (tek40:reset) - (tek40:graphics) - (tek40:linetype 0) - (tek40:move 100 100) - (tek40:draw 200 100) - (tek40:draw 200 200) - (tek40:draw 100 200) - (tek40:draw 100 100) - (do ((i 0 (+ 1 i))) - ((> i 15)) - (tek40:linetype i) - (tek40:move (+ (* 50 i) 100) 100) - (tek40:put-text (+ (* 50 i) 100) 100 (number->string i)) - (tek40:move (+ (* 50 i) 100) 100) - (tek40:draw (+ (* 50 i) 200) 200)) - (tek40:linetype 0) - (tek40:text)) |