mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-11 00:00:49 +02:00
92 lines
2.7 KiB
Scheme
92 lines
2.7 KiB
Scheme
;"tek40.scm", Tektronix 4000 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.
|
|
|
|
;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))
|