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))