DataMuseum.dk

top - download

    Length: 5819 (0x16bb)
    Types: TextFile
    Names: »graphics.scm.4«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─ ⟦this⟧ »EUUGD11/gnu-31mar87/scheme/scm/graphics.scm.4« 

TextFile

;;; -*-Scheme-*-
;;;
;;;	Copyright (c) 1984 Massachusetts Institute of Technology
;;;
;;;	This material was developed by the Scheme project at the
;;;	Massachusetts Institute of Technology, Department of
;;;	Electrical Engineering and Computer Science.  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. Users of this software agree to make their best efforts (a)
;;;	to return to the MIT Scheme project any improvements or
;;;	extensions that they make, so that these may be included in
;;;	future releases; and (b) to inform MIT of noteworthy uses of
;;;	this software.
;;;
;;;	3.  All materials developed as a consequence of the use of
;;;	this software shall duly acknowledge such use, in accordance
;;;	with the usual standards of acknowledging credit in academic
;;;	research.
;;;
;;;	4. MIT has made no warrantee or representation that the
;;;	operation of this software will be error-free, and MIT is
;;;	under no obligation to provide any services, by way of
;;;	maintenance, update, or otherwise.
;;;
;;;	5.  In conjunction with products arising from the use of this
;;;	material, there shall be no use of the name of the
;;;	Massachusetts Institute of Technology nor of any adaptation
;;;	thereof in any advertising, promotional, or sales literature
;;;	without prior written consent from MIT in each case.
;;;

;;;; Graphics Interface

(declare (usual-integrations))
\f


(define init-graphics)
(define clear-graphics)
(define draw-line-to)
(define position-pen)
(define draw-point)
(define clear-point)
(define is-point-on?)

(define graphics-package
  (make-package graphics-package
    ((graphics-move (make-primitive-procedure 'GRAPHICS-MOVE))
     (graphics-line (make-primitive-procedure 'GRAPHICS-LINE))
     (graphics-clear (make-primitive-procedure 'GRAPHICS-CLEAR))
     (graphics-pixel (make-primitive-procedure 'GRAPHICS-PIXEL))
     (graphics-set-alu! (make-primitive-procedure 'GRAPHICS-SET-ALU!))
     (graphics-set-mask! (make-primitive-procedure 'GRAPHICS-SET-MASK!))
     (alpha-raster? (make-primitive-procedure 'ALPHA-RASTER?))
     (graphics-raster? (make-primitive-procedure 'GRAPHICS-RASTER?))
     (toggle-alpha-raster (make-primitive-procedure 'TOGGLE-ALPHA-RASTER))
     (toggle-graphics-raster (make-primitive-procedure 'TOGGLE-GRAPHICS-RASTER))
     (load-picture (make-primitive-procedure 'LOAD-PICTURE))
     (store-picture (make-primitive-procedure 'STORE-PICTURE))
     (alu-nop 0)
     (alu-set 1)
     (alu-clear 2)
     (alu-change 3)
     (*graphics-alu* 1)
     (*graphics-color* 1)
     (*graphics-linestyle* 0)
     (*linestyle-masks* #(-1                  ; 0
			  #b0000111100001111  ; 1
			  #b0001000100010001  ; 2
			  #b1111000110001111  ; 3
			  #b1010101010101010  ; 4
			  -1                  ; 5
			  -1                  ; 6
			  -1                  ; 7
			  )))
\f


(define (set-alu! alu)
  (without-interrupts
   (lambda ()
     (graphics-set-alu! alu)
     (set! *graphics-alu* alu))))

(define (set-color! color)
  (without-interrupts
   (lambda ()
     (cond ((zero? color) (set-alu! alu-clear))
	   ((negative? color) (set-alu! alu-change))
	   (else (set-alu! alu-set)))
     (set! *graphics-color* color))))

(define (graphics-set-linestyle! style)
  (graphics-set-mask! (vector-ref *linestyle-masks* style)))

(define (set-linestyle! style)
  (without-interrupts
   (lambda ()
     (graphics-set-linestyle! style)
     (set! *graphics-linestyle* style))))

(define (with-line-style style thunk)
  (dynamic-wind (lambda () (graphics-set-linestyle! style))
                thunk
                (lambda () (graphics-set-linestyle! *graphics-linestyle*))))
\f


(define (draw-line x y #!optional style)
  (if (unassigned? style)
      (graphics-line (round x) (round y))
      (dynamic-wind (lambda ()
		      (graphics-set-linestyle! style))
		    (lambda ()
		      (graphics-line (round x) (round y)))
		    (lambda ()
		      (graphics-set-linestyle! *graphics-linestyle*)))))

(define (erase-line x y)
  (dynamic-wind (lambda () (graphics-set-alu! alu-clear)
                           (graphics-set-linestyle! 0))
                (lambda () (graphics-line (round x) (round y)))
                (lambda () (graphics-set-linestyle! *graphics-linestyle*)
                           (graphics-set-alu! *graphics-alu*))))

(define (move-pen x y)
  (graphics-move (round x) (round y)))

(define (draw-pixel x y #!optional op)
  (if (unassigned? op)
      (graphics-pixel (round x) (round y))
      (dynamic-wind (lambda () (graphics-set-alu! op))
		    (lambda () (graphics-pixel (round x) (round y)))
		    (lambda () (graphics-set-alu! *graphics-alu*)))))

(define (set-graphics-raster-state! semaphore)
  (disjunction (eq? (graphics-raster?) semaphore)
	       (toggle-graphics-raster)))

(define (set-alpha-raster-state! semaphore)
  (disjunction (eq? (alpha-raster?) semaphore)
	       (toggle-alpha-raster)))
\f


;;;; Student Graphics Interface

(set! draw-line-to
(lambda (x y)
  (graphics-line (round x) (round y))))

(set! position-pen
(lambda (x y)
  (graphics-move (round x) (round y))))

(define ((graphics-point-procedure alu) x y)
  (dynamic-wind (lambda () (graphics-set-alu! alu))
	        (lambda () (graphics-pixel (round x) (round y)))
		(lambda () (graphics-set-alu! *graphics-alu*))))

(set! draw-point (graphics-point-procedure alu-set))
(set! clear-point (graphics-point-procedure alu-clear))
(set! is-point-on? (graphics-point-procedure alu-nop))

(set! clear-graphics
(lambda ()
  (graphics-clear)
  (graphics-move 0 0)))

(set! init-graphics
(lambda ()
  (set-alu! alu-set)
  (set-linestyle! 0)
  (clear-graphics)))

))