summaryrefslogtreecommitdiffstats
path: root/tek41.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
commit8ffbc2df0fde83082610149d24e594c1cd879f4a (patch)
treea2be9aad5101c5e450ad141d15c514bc9c2a2963 /tek41.scm
downloadslib-8ffbc2df0fde83082610149d24e594c1cd879f4a.tar.gz
slib-8ffbc2df0fde83082610149d24e594c1cd879f4a.zip
Import Upstream version 2a6upstream/2a6
Diffstat (limited to 'tek41.scm')
-rw-r--r--tek41.scm147
1 files changed, 147 insertions, 0 deletions
diff --git a/tek41.scm b/tek41.scm
new file mode 100644
index 0000000..988f8ea
--- /dev/null
+++ b/tek41.scm
@@ -0,0 +1,147 @@
+;"tek41.scm", Tektronix 4100 series graphics support in Scheme.
+;Copyright (C) 1992, 1994 Aubrey Jaffer
+;
+;Permission to copy this software, to redistribute it, 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. Let me know if you test or fix it.
+
+;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.
+
+(define esc-string (string (integer->char #o33)))
+
+(define tek41:init
+ (string-append
+ esc-string "%!0"
+ ;;1. set tek mode
+ esc-string "MN0"
+ ;;2. set character path to 0 (characters placed equal to rotation)
+ esc-string "MCB7C;"
+ ;;3. set character size to 59 height
+ esc-string "MQ1"
+ ;;4. set character precision to string
+ esc-string "MT1"
+ ;;5. set character text index to 1
+ esc-string "MG1"
+ ;;6. set character write mode to overstrike
+ esc-string "RK!"
+ ;;7. clear the view
+ esc-string "SK!"
+ ;;8. clear the segments
+ esc-string "LZ"
+ ;;9. clear the dialog buffer
+ esc-string "%!1"
+ ;;10. set ansi mode
+ ))
+
+(define (tek41:init) (display tek41:init-str) (force-output))
+
+(define (tek41:reset)
+ (string-append
+ esc-string "%!0"
+ ;;1. set tek mode
+ esc-string "LZ"
+ ;;2. clear the dialog buffer
+ esc-string "%!1"
+ ;;3. set ansi mode
+ ))
+
+(define (tek41:reset) (display tek41:reset-str) (force-output))
+
+(define tek41:graphics-str
+ (string-append
+ esc-string "%!0"
+ ;;1. set tek mode
+ esc-string (string (integer->char #o14))
+ ;;2. clear the screen
+ esc-string "LV0"
+ ;;3. set dialog area invisible
+ ))
+
+(define (tek41:graphics) (display tek41:graphics-str) (force-output))
+
+(define tek41:text-str
+ (string-append
+ esc-string "LV1"
+ ;;1. set dialog area visible
+ esc-string "%!1"
+ ;;2. set ansi mode
+ ))
+
+(define (tek41:text) (display tek41:text-str) (force-output))
+
+(define tek41:move-str
+ (string-append esc-string "LF"))
+
+(define (tek41:move x y)
+ (display tek41:move-str)
+ (tek41:encode-x-y x y)
+ (force-output))
+
+(define tek41:draw-str
+ (string-append esc-string "LG"))
+
+(define (tek41:draw x y)
+ (display tek41:draw-str)
+ (tek41:encode-x-y x y)
+ (force-output))
+
+(define tek41:set-marker-str (string-append esc-string "MM"))
+(define tek41:draw-marker-str (string-append esc-string "LH"))
+
+(define (tek41:point x y number)
+ (display tek41:set-marker-str)
+ (tek41:encode-int (remainder (max number 0) 11))
+ (display tek41:draw-marker-str)
+ (tek41:encode-x-y x y)
+ (force-output))
+
+(define (tek41:encode-x-y x y)
+ (let ((hix (+ (quotient x 128) 32))
+ (lox (+ (modulo (quotient x 4) 32) 64))
+ (hiy (+ (quotient y 128) 32))
+ (loy (+ (modulo (quotient y 4) 32) 96))
+ (eb (+ (* (modulo y 4) 4) (modulo x 4) 96)))
+ (if (positive? hiy) (write-char (integer->char hiy)))
+ (if (positive? eb) (write-char (integer->char eb)))
+ (if (positive? (+ loy eb hix)) (write-char (integer->char loy)))
+ (if (positive? hix) (write-char (integer->char hix)))
+ (write-char (integer->char lox))))
+
+(define (tek41:encode-int number)
+ (let* ((mag (abs number))
+ (hi1 (+ (quotient mag 1024) 64))
+ (hi2 (+ (modulo (quotient mag 16) 64) 64))
+ (lo (+ (modulo mag 16) 32)))
+ (if (>= number 0) (set! lo (+ lo 16)))
+ (if (not (= hi1 64)) (write-char (integer->char hi1)))
+ (if (or (not (= hi2 64))
+ (not (= hi1 64)))
+ (write-char (integer->char hi2)))
+ (write-char (integer->char lo))))
+
+(define (test)
+ (tek41:init)
+ (tek41:reset)
+ (tek41:graphics)
+ (do ((i 0 (+ 1 i)))
+ ((> i 15))
+ (tek41:linetype i)
+ (tek41:move (+ (* 200 i) 1000) 1000)
+ (tek41:draw (+ (* 200 i) 2000) 2000))
+ (tek41:text))