325 lines
12 KiB
Common Lisp
325 lines
12 KiB
Common Lisp
|
||
; -*- Mode: Lisp -*- Filename: pgr.s
|
||
|
||
; Last Revision: 7-May-87
|
||
|
||
;--------------------------------------------------------------------------;
|
||
; ;
|
||
; TI SCHEME -- PCS Compiler ;
|
||
; Copyright 1985, 1986 (c) Texas Instruments ;
|
||
; ;
|
||
; David Bartley, Rusty Haddock ;
|
||
; ;
|
||
; MIT-Compatible Graphics Routines ;
|
||
; ;
|
||
;--------------------------------------------------------------------------;
|
||
|
||
; Revisions:
|
||
; ds - added support for EGA modes 14, 16
|
||
; rb 11/5/86 - modified for clipping
|
||
; rb 11/17/86 - graphics windows (they don't remember their state, though)
|
||
; mrm 5/07/87 - special handling for setting mode 3
|
||
; ttc 3/11/88 - added support for VGA mode 18
|
||
|
||
(begin
|
||
(define clear-graphics)
|
||
(define clear-point)
|
||
(define draw-point)
|
||
(define draw-line-to)
|
||
(define is-point-on?)
|
||
(define position-pen)
|
||
(define set-pen-color!)
|
||
(define set-video-mode!)
|
||
(define get-video-mode)
|
||
(define draw-box-to)
|
||
(define draw-filled-box-to)
|
||
(define set-palette!)
|
||
(define point-color) ;new with 3.0
|
||
(define set-clipping-rectangle!) ; "
|
||
(define graphics-window) ; "
|
||
(define get-pen-position) ; "
|
||
(define get-pen-color) ; "
|
||
(define current-graphics-window) ; "
|
||
(define reset-graphics) ;not documented
|
||
)
|
||
|
||
;;; A small note about the global variable PCS-MACHINE-TYPE:
|
||
;;;
|
||
;;; PCS-MACHINE-TYPE = 0 Machine type unknown
|
||
;;; = 1 TIPC -or- TI Bus-Pro in TIPC mode
|
||
;;; = 252 IBM-PC/AT
|
||
;;; = 253 IBM-PC/jr
|
||
;;; = 254 IBM-PC/XT
|
||
;;; = 255 IBM-PC -or- TI Bus-Pro in PC/AT mode
|
||
;;;
|
||
;;; No variable CURRENTLY indicates whether or not the PC has
|
||
;;; bit-mapped graphics capabilities. (This would be nice though.)
|
||
|
||
(define *graphics-colors* ; *GRAPHICS-COLORS*
|
||
(if (=? pcs-machine-type 1)
|
||
'((black . 0) (blue . 1) (red . 2) (magenta . 3)
|
||
(green . 4) (cyan . 5) (yellow . 6) (white . 7))
|
||
'((black . 0) (cyan . 1) (magenta . 2) (white . 3)))) ; IBM mode #4
|
||
|
||
(define *character-boxes* ; horiz x vert by graphics mode
|
||
'((TI 9 . 12) (4 8 . 8) (14 8 . 8) (16 8 . 14) (18 8 . 16)))
|
||
|
||
|
||
;;; extended MIT Graphics Procedures
|
||
;;;
|
||
;;; TI User coordinates: -360 <= X <= +359
|
||
;;; -150 <= Y <= +149
|
||
;;; IBM User coordinates: -160 <= X <= +159 For 320x200/4-color mode (#4)
|
||
;;; -100 <= Y <= +99
|
||
;;; IBM User coordinates: -320 <= X <= +319 For 640x200/16-color mode (#14)
|
||
;;; -100 <= Y <= +99
|
||
;;; IBM User coordinates: -320 <= X <= +319 For 640x350/16-color mode (#16)
|
||
;;; -175 <= Y <= +174
|
||
;;; IBM User coordinates: -320 <= X <= +319 For 640x480/16-color mode (#18)
|
||
;;; -240 <= Y <= +239
|
||
;;;
|
||
;;; for IBM, mode 4 values are the default.
|
||
;;;
|
||
|
||
(let ((cur-x '()) ; X,Y should be in fixnum range, else get
|
||
(cur-y '()) ; "invalid operand" error when %GRAPHICS executes
|
||
(cur-w 'screen) ; use 'screen for screen, else have window here
|
||
; note 'screen and 'console are *not* synonyms
|
||
(cur-color '())
|
||
(max-x (if (=? pcs-machine-type 1) 719 319))
|
||
(max-y (if (=? pcs-machine-type 1) 299 199))
|
||
(mid-x (if (=? pcs-machine-type 1) 360 160))
|
||
(mid-y (if (=? pcs-machine-type 1) 149 99))
|
||
(min-x 0)
|
||
(min-y 0)
|
||
(num-clrs (if (=? pcs-machine-type 1) 8 4)))
|
||
|
||
(begin
|
||
|
||
(if (=? pcs-machine-type 1)
|
||
(set! clear-graphics ; CLEAR-GRAPHICS (TIPC)
|
||
(lambda ()
|
||
(reset-graphics)
|
||
(if (not (eq? cur-w 'screen))
|
||
(begin
|
||
(graphics-window cur-w)
|
||
(position-pen 0 0)
|
||
(%graphics 7 0 0 1024 1024 0 0)) ; clear window to black
|
||
(begin
|
||
(%graphics 0 0 0 0 0 0 0) ; Clear the graphics planes
|
||
(%graphics 0 3 0 0 0 0 0))) ; Enable both text & graphics planes
|
||
'()))
|
||
|
||
(set! clear-graphics ; CLEAR-GRAPHICS (IBM)
|
||
(lambda ()
|
||
(reset-graphics)
|
||
(if (not (eq? cur-w 'screen))
|
||
(begin
|
||
(graphics-window cur-w)
|
||
(position-pen 0 0)
|
||
(%graphics 7 0 0 1024 1024 0 0)) ; clear window to black
|
||
(%graphics 0 (get-video-mode)
|
||
0 0 0 0 0)) ; IBM graphics and text are on same
|
||
; plane and will SCROLL together!!!
|
||
(%graphics 2 1 1 0 0 0 0) ; Ensure proper colors are used - CGA
|
||
'())))
|
||
|
||
(set! reset-graphics
|
||
(lambda ()
|
||
(if (=? pcs-machine-type 1)
|
||
(begin ;TI
|
||
(set! max-x 719)
|
||
(set! max-y 299)
|
||
(set! mid-x 359)
|
||
(set! mid-y 149)
|
||
(set! min-x 0)
|
||
(set! min-y 0)
|
||
(set! cur-color 7)
|
||
(position-pen 0 0))
|
||
(case (get-video-mode) ;IBM
|
||
(4
|
||
(set! max-x 319)
|
||
(set! max-y 199)
|
||
(set! mid-x 160)
|
||
(set! mid-y 99)
|
||
(set! min-x 0)
|
||
(set! min-y 0)
|
||
(set! num-clrs 4)
|
||
(set! *graphics-colors*
|
||
'((black . 0) (cyan . 1) (magenta . 2) (white . 3)))
|
||
(set! cur-color (sub1 num-clrs))
|
||
(position-pen 0 0))
|
||
((14 16 18)
|
||
(set! max-x 639)
|
||
(set! mid-x 320)
|
||
(set! min-x 0)
|
||
(set! min-y 0)
|
||
(set! num-clrs 16)
|
||
(set! *graphics-colors*
|
||
'((black . 0) (blue . 1) (green . 2) (cyan . 3)
|
||
(red . 4) (magenta . 5) (brown . 6) (white . 7)
|
||
(gray . 8) (light-blue . 9)
|
||
(light-green . 10) (light-cyan . 11)
|
||
(light-red . 12) (light-magenta . 13)
|
||
(yellow . 14) (intense-white . 15)))
|
||
(set! cur-color (sub1 num-clrs))
|
||
(case (get-video-mode)
|
||
(14
|
||
(set! max-y 199)
|
||
(set! mid-y 99))
|
||
(16
|
||
(set! max-y 349)
|
||
(set! mid-y 174))
|
||
(18
|
||
(set! max-y 479)
|
||
(set! mid-y 238)))
|
||
(position-pen 0 0))
|
||
(else
|
||
'())) ; for other modes, do nothing
|
||
)))
|
||
|
||
(set! draw-point ; DRAW-POINT
|
||
(lambda (x y)
|
||
(%graphics 1 (+ x mid-x) (- mid-y y) cur-color 0 0 0)
|
||
'()))
|
||
|
||
(set! clear-point ; CLEAR-POINT
|
||
(lambda (x y)
|
||
(%graphics 1 (+ x mid-x) (- mid-y y) 0 0 0 0)
|
||
'()))
|
||
|
||
(set! is-point-on? ; IS-POINT-ON?
|
||
(lambda (x y)
|
||
(positive? (%graphics 4 (+ x mid-x) (- mid-y y) 0 0 0 0))))
|
||
|
||
(set! point-color ; POINT-COLOR
|
||
(lambda (x y)
|
||
(%graphics 4 (+ x mid-x) (- mid-y y) 0 0 0 0)))
|
||
|
||
(set! position-pen ; POSITION-PEN
|
||
(lambda (x y)
|
||
(set! cur-x (+ x mid-x))
|
||
(set! cur-y (- mid-y y))
|
||
'()))
|
||
|
||
(set! get-pen-position ; GET-PEN-POSITION
|
||
(lambda ()
|
||
(cons (- cur-x mid-x) (- mid-y cur-y))))
|
||
|
||
(set! draw-line-to ; DRAW-LINE-TO
|
||
(lambda (x y)
|
||
(let ((old-x cur-x)
|
||
(old-y cur-y))
|
||
(position-pen x y)
|
||
(%graphics 3 old-x old-y cur-x cur-y cur-color 0)
|
||
'())))
|
||
|
||
(set! set-pen-color! ; SET-PEN-COLOR!
|
||
(lambda (color)
|
||
(set! cur-color
|
||
(if (integer? color)
|
||
(remainder (abs color) num-clrs)
|
||
(let ((entry (assq color *graphics-colors*)))
|
||
(if entry
|
||
(remainder (abs (cdr entry)) num-clrs)
|
||
(-1+ num-clrs)))))))
|
||
|
||
(set! get-pen-color ; GET-PEN-COLOR
|
||
(lambda () cur-color))
|
||
|
||
(set! set-video-mode! ; SET-VIDEO-MODE!
|
||
(lambda (mode)
|
||
(%graphics 0 mode 0 0 0 0 0)
|
||
(case pcs-machine-type
|
||
(1 ;TI mode - do nothing special
|
||
'())
|
||
(else ;default to IBM
|
||
(case mode
|
||
(3 ;IBM CGA
|
||
(window-set-attribute! pcs-status-window
|
||
'text-attributes #x70))
|
||
((14 16 18) ;IBM EGA or VGA
|
||
(window-set-attribute! pcs-status-window
|
||
'text-attributes #x87)))
|
||
(set! cur-w 'screen)
|
||
(if (<> mode 3)
|
||
(reset-graphics)))) ;if you're switching modes in IBM,
|
||
;it makes sense to do this too
|
||
'()))
|
||
|
||
(set! get-video-mode ; GET-VIDEO-MODE
|
||
(lambda ()
|
||
(%graphics 5 0 0 0 0 0 0)))
|
||
|
||
(set! draw-box-to ; DRAW-BOX-TO
|
||
(lambda (x y)
|
||
(let ((old-x cur-x)
|
||
(old-y cur-y))
|
||
(set! cur-x (+ x mid-x))
|
||
(set! cur-y (- mid-y y))
|
||
(%graphics 6 old-x old-y cur-x cur-y cur-color 0)
|
||
'())))
|
||
|
||
(set! draw-filled-box-to ; DRAW-FILLED-BOX-TO
|
||
(lambda (x y)
|
||
(let ((old-x cur-x)
|
||
(old-y cur-y))
|
||
(set! cur-x (+ x mid-x))
|
||
(set! cur-y (- mid-y y))
|
||
(%graphics 7 old-x old-y cur-x cur-y cur-color 0)
|
||
'())))
|
||
|
||
(set! set-palette! ; SET-PALETTE!
|
||
(lambda (arg1 arg2)
|
||
(when (not (and (integer? arg1)
|
||
(integer? arg2)))
|
||
(%error-invalid-operand-list 'SET-PALETTE! arg1 arg2))
|
||
(when (and (>=? pcs-machine-type #xFC) ; IBM
|
||
(=? arg1 1)
|
||
(=? (get-video-mode) 4))
|
||
(set! *graphics-colors*
|
||
(if (odd? arg2)
|
||
'((black . 0)(cyan . 1)(magenta . 2)(white . 3))
|
||
'((black . 0)(green . 1)(red . 2)(yellow . 3)))))
|
||
(%graphics 2 arg1 arg2 0 0 0 0)
|
||
'()))
|
||
|
||
(set! set-clipping-rectangle! ; SET-CLIPPING-RECTANGLE!
|
||
(lambda (x1 y1 x2 y2) ;left, top, right, bottom
|
||
(%graphics 8 (min max-x (max min-x (+ x1 mid-x)))
|
||
(min max-y (max min-y (- mid-y y1)))
|
||
(max min-x (min max-x (+ x2 mid-x)))
|
||
(max min-y (min max-y (- mid-y y2))) 0 0)
|
||
'()))
|
||
|
||
(set! current-graphics-window ; CURRENT-GRAPHICS-WINDOW
|
||
(lambda () cur-w))
|
||
|
||
(set! graphics-window ; GRAPHICS-WINDOW
|
||
(lambda (window)
|
||
(let ((w (if (eq? window 'screen) 'console window)))
|
||
(let ((size (window-get-size w))
|
||
(pos (window-get-position w))
|
||
(cbox (cdr (assv (cond ((= pcs-machine-type 1) 'TI)
|
||
((>= pcs-machine-type #xFC) (get-video-mode))
|
||
(else pcs-machine-type))
|
||
*character-boxes*))))
|
||
(if (null? cbox) (error "Current video mode is not a graphics mode." (get-video-mode)))
|
||
(let* ((left (* (cdr pos) (car cbox)))
|
||
(top (* (car pos) (cdr cbox)))
|
||
(right (sub1 (+ left (* (cdr size) (car cbox)))))
|
||
(bottom (sub1 (+ top (* (car size) (cdr cbox))))))
|
||
(%graphics 8 left top right bottom 0 0)
|
||
(set! mid-x (quotient (+ left right) 2))
|
||
(set! mid-y (quotient (+ top bottom) 2))
|
||
(set! min-x left)
|
||
(set! min-y top)
|
||
(set! max-x right)
|
||
(set! max-y bottom)
|
||
(set! cur-w window)
|
||
(list (list (- min-x mid-x) (- mid-y min-y)
|
||
(- max-x mid-x) (- mid-y max-y))
|
||
(list left top right bottom)))))))
|
||
|
||
'#!false))
|
||
|