150 lines
4.5 KiB
ArmAsm
150 lines
4.5 KiB
ArmAsm
|
;;; Sample graphics routines using the %GRAPHICS primitive.
|
|||
|
|
|||
|
;;; Note that %GRAPHICS may change in meaning in future versions of the system,
|
|||
|
;;; as it has between versions 2.0 and 3.0.
|
|||
|
;;; Using macros or define-integrables to protect your code
|
|||
|
;;; from explicit uses of %GRAPHICS is highly recommended.
|
|||
|
|
|||
|
;;; Determine what type of video adapter we have.
|
|||
|
(define video-type
|
|||
|
(lambda ()
|
|||
|
(if (= pcs-machine-type 1)
|
|||
|
;; it's TI
|
|||
|
'ti
|
|||
|
;; it's IBM
|
|||
|
(let ((mode (%graphics 5 0 0 0 0 0 0))) ;; get video mode
|
|||
|
(case mode
|
|||
|
(3 'cga)
|
|||
|
((14 16) 'ega)
|
|||
|
(else 'cga))))))
|
|||
|
|
|||
|
|
|||
|
;;; Initialize Graphics (sets palette registers; clears graphics planes)
|
|||
|
(define grinit
|
|||
|
(lambda ()
|
|||
|
(case (video-type)
|
|||
|
(ti (%graphics 0 0 0 0 0 0 0) ;; clear graphics
|
|||
|
(window-clear (make-window "" '())))
|
|||
|
(cga (%graphics 0 4 0 0 0 0 0) ;; 4-color graphics mode
|
|||
|
(%graphics 2 0 0 0 0 0 0) ;; set background to black
|
|||
|
(%graphics 2 1 0 0 0 0 0)) ;; use black,red,green,brown
|
|||
|
(ega (%graphics 0 16 0 0 0 0 0) ;; 16-color graphics mode
|
|||
|
(%graphics 2 0 0 0 0 0 0) ;; not necessary here
|
|||
|
(%graphics 2 1 0 0 0 0 0))
|
|||
|
)))
|
|||
|
|
|||
|
|
|||
|
; Set point
|
|||
|
(define-integrable setp
|
|||
|
(lambda (x y color) (%graphics 1 x y color 0 0 0)))
|
|||
|
|
|||
|
; Reset point (turns it off)
|
|||
|
(define-integrable resetp
|
|||
|
(lambda (x y) (%graphics 2 x y 0 0 0 0)))
|
|||
|
|
|||
|
; Draw Line
|
|||
|
(define-integrable line
|
|||
|
(lambda (x1 y1 x2 y2 color)
|
|||
|
(%graphics 3 x1 y1 x2 y2 color 0)))
|
|||
|
|
|||
|
; Read Point (returns its color)
|
|||
|
(define-integrable point
|
|||
|
(lambda (x y) (%graphics 4 x y 0 0 0 0)))
|
|||
|
|
|||
|
; %graphics 5 is identical to get-video-mode
|
|||
|
|
|||
|
; Draw box
|
|||
|
(define-integrable draw-box
|
|||
|
(lambda (x1 y1 x2 y2 color)
|
|||
|
(%graphics 6 x1 y1 x2 y2 color 0)))
|
|||
|
|
|||
|
; Draw Filled Box
|
|||
|
(define-integrable draw-filled-box
|
|||
|
(lambda (x1 y1 x2 y2 color)
|
|||
|
(%graphics 7 x1 y1 x2 y2 color 0)))
|
|||
|
|
|||
|
|
|||
|
; Kaleidoscope Program [Translated from Basic]
|
|||
|
|
|||
|
; Note: To stop this program, press the "q" key. To start a new pattern
|
|||
|
; going, press any other key.
|
|||
|
(alias kldscope kald)
|
|||
|
(alias kaleidosope kald)
|
|||
|
(define kald
|
|||
|
(lambda ()
|
|||
|
(let* ((old-video-mode (%graphics 5 0 0 0 0 0 0))
|
|||
|
(vmode (video-type))
|
|||
|
(accel-range (case vmode (ti 12) (cga 6) (ega 12)))
|
|||
|
(accel-adj (case vmode (ti 5) (cga 3) (ega 5)))
|
|||
|
(usable-colors (case vmode (ti 7) (cga 3) (ega 15)))
|
|||
|
(wh (case vmode (ti 360) (cga 160) (ega 320)))
|
|||
|
(mi (case vmode (ti 145) (cga 75) (ega 150)))
|
|||
|
(ycenter-offset (case vmode (ti 5) (cga 25) (ega 25)))
|
|||
|
;; Add 5/25/25 (TI/CGA/EGA) to y-coordinates 'cause we said that the
|
|||
|
;; screens are only 290/150/300-pixels high when, in actuality,
|
|||
|
;; they're 300/200/350.
|
|||
|
(m1 (+ mi 1))
|
|||
|
(xv1 nil)
|
|||
|
(xv2 nil)
|
|||
|
(yv1 nil)
|
|||
|
(yv2 nil)
|
|||
|
)
|
|||
|
(letrec
|
|||
|
(
|
|||
|
(quit-kald
|
|||
|
(lambda ()
|
|||
|
(grinit)
|
|||
|
(%graphics 0 old-video-mode 0 0 0 0 0)
|
|||
|
(window-set-cursor! 'console 0 0)
|
|||
|
(gc)
|
|||
|
*the-non-printing-object*
|
|||
|
))
|
|||
|
(loop
|
|||
|
(lambda (a n color x1 y1 x2 y2)
|
|||
|
(cond ((positive? a)
|
|||
|
(let ((2x1 (+ x1 x1))
|
|||
|
(2y1 (+ y1 y1))
|
|||
|
(2x2 (+ x2 x2))
|
|||
|
(2y2 (+ y2 y2))
|
|||
|
(w wh)
|
|||
|
(m (+ mi ycenter-offset)))
|
|||
|
(line (+ w 2x1) (- m y1) (+ w 2x2) (- m y2) color) ; 1
|
|||
|
(line (- w 2y1) (+ m x1) (- w 2y2) (+ m x2) color) ; 2
|
|||
|
(line (- w 2x1) (- m y1) (- w 2x2) (- m y2) color) ; 3
|
|||
|
(line (- w 2y1) (- m x1) (- w 2y2) (- m x2) color) ; 4
|
|||
|
(line (- w 2x1) (+ m y1) (- w 2x2) (+ m y2) color) ; 5
|
|||
|
(line (+ w 2y1) (- m x1) (+ w 2y2) (- m x2) color) ; 6
|
|||
|
(line (+ w 2x1) (+ m y1) (+ w 2x2) (+ m y2) color) ; 7
|
|||
|
(line (+ w 2y1) (+ m x1) (+ w 2y2) (+ m x2) color) ; 8
|
|||
|
(if (positive? n)
|
|||
|
(loop (- a 1)
|
|||
|
(- n 1)
|
|||
|
color
|
|||
|
(remainder (+ x1 xv1) m1)
|
|||
|
(remainder (+ y1 yv1) m1)
|
|||
|
(remainder (+ x2 xv2) m1)
|
|||
|
(remainder (+ y2 yv2) m1))
|
|||
|
(restart))))
|
|||
|
((not (char-ready?))
|
|||
|
(set! xv1 (- (random accel-range) accel-adj))
|
|||
|
(set! yv1 (- (random accel-range) accel-adj))
|
|||
|
(set! xv2 (- (random accel-range) accel-adj))
|
|||
|
(set! yv2 (- (random accel-range) accel-adj))
|
|||
|
(loop (random 10) n (+ (random usable-colors) 1) x1 y1 x2 y2))
|
|||
|
((eq? (char-upcase (read-char)) '#\Q)
|
|||
|
(quit-kald))
|
|||
|
(else
|
|||
|
(restart)))))
|
|||
|
(restart
|
|||
|
(lambda ()
|
|||
|
(grinit)
|
|||
|
(randomize 0)
|
|||
|
(loop 0 (+ 50 (random 200)) 0
|
|||
|
(+ (random mi) 1)
|
|||
|
(+ (random mi) 1)
|
|||
|
(+ (random mi) 1)
|
|||
|
(+ (random mi) 1)))))
|
|||
|
(begin
|
|||
|
(flush-input)
|
|||
|
(restart))))))
|
|||
|
|