DataMuseum.dk

top - download

    Length: 10035 (0x2733)
    Types: TextFile
    Names: »bgraph.scm.5«

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

TextFile

;;; -*-Scheme-*-
;;;
;;;	Copyright (c) 1986 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.
;;;

;;;; Bobcat (Starbase) Graphics System

(declare (usual-integrations))
\f


;;; User Level Functions

(define init-graphics)
(define clear-graphics)
(define draw-line-to)
(define position-pen)
(define draw-circle)
(define draw-point)
(define clear-point)
(define with-color)
(define with-style)
(define with-mode)
(define graphics-text)

(define graphics-package
  (make-environment

(define graphics-move 
  (make-primitive-procedure 'GRAPHICS-MOVE))

(define graphics-line
  ;; On Gator this is called GRAPHICS-LINE
  (make-primitive-procedure 'GRAPHICS-DRAW))

(define graphics-clear
  (make-primitive-procedure 'GRAPHICS-CLEAR))

(define graphics-pixel
  (make-primitive-procedure 'GRAPHICS-PIXEL))

(define graphics-set-line-style
  (make-primitive-procedure 'GRAPHICS-SET-LINE-STYLE))

(define graphics-set-line-color
  (make-primitive-procedure 'GRAPHICS-SET-LINE-COLOR))

(define graphics-set-drawing-mode
  (make-primitive-procedure 'GRAPHICS-SET-DRAWING-MODE))

(define graphics-done
  (make-primitive-procedure 'GRAPHICS-DONE))

(define graphics-initialize
  (make-primitive-procedure 'GRAPHICS-INITIALIZE))

(define graphics-label
  (make-primitive-procedure 'GRAPHICS-LABEL))

(define graphics-set-letter
  (make-primitive-procedure 'GRAPHICS-SET-LETTER))

(define graphics-set-rotation
  (make-primitive-procedure 'GRAPHICS-SET-ROTATION))

(define graphics-circle
  (make-primitive-procedure 'GRAPHICS-CIRCLE))

\f


;;; These magic numbers are dependent on the underlying 
;;; graphics package used.

(define drawing-mode:dominant 3)
(define drawing-mode:nondominant 1)
(define drawing-mode:erase 6)
(define drawing-mode:complement 10)

(define *graphics-drawing-mode*
  drawing-mode:dominant)

(define line-style:solid 0)
(define line-style:dash 1)
(define line-style:dot 2)
(define line-style:dash-dot 3)
(define line-style:dash-dot-dot 4)
(define line-style:long-dash 5)
(define line-style:center-dash 6)
(define line-style:center-dash-dash 7)

(define *graphics-line-style* line-style:solid)

(define *graphics-line-color* 1)

\f


;;; Basic Graphics Stuff.
;;; Great Pain to maintain gator compatability. No longer does
;;; rounding of coordinates, because Bobcat primitives take
;;; FLONUMS.

(define (init-graphics)
  (graphics-initialize)
  (set-line-style! line-style:solid)
  (set-drawing-mode! drawing-mode:dominant)
  (set-line-color! 1)
  (set-default-character-attributes!)
  '())

(define (clear-graphics)
  (graphics-clear)
  (graphics-move 0 0))

(define ((graphics-point-procedure drawing-mode) x y)
  (let ((old-mode))
    (dynamic-wind 
     (lambda ()
       (set! old-mode (set! *graphics-drawing-mode* drawing-mode))
       (graphics-set-drawing-mode *graphics-drawing-mode*))
     (lambda ()
       (graphics-pixel x y))
     (lambda ()
       (set! *graphics-drawing-mode* (set! old-mode drawing-mode))
       (graphics-set-drawing-mode *graphics-drawing-mode*)))))

(define draw-point (graphics-point-procedure drawing-mode:dominant))
(define clear-point (graphics-point-procedure drawing-mode:erase))

\f


;;; More advanced stuff

(define (set-line-style style)
  (graphics-set-line-style style)
  (set! *graphics-line-style* style))

(define (draw-line x y #!optional style)
  (if (unassigned? style)
      (graphics-line x y)
      (with-style style 
        (lambda ()
	  (graphics-line x y)))))

(define (erase-line x y)
  (with-mode drawing-mode:erase
    (lambda () 
      (graphics-line x y))))

(define (draw-pixel x y #!optional mode)
  (if (unassigned? mode)
      (graphics-pixel (round x) (round y))
      (with-mode mode
        (lambda () 
	  (graphics-pixel x y)))))
		      
\f

;;; The rest may not be Gator compatable

(define (set-line-style! style)
  (set-line-style style))

(define (set-line-color! color)
  (graphics-set-line-color color)
  (set! *graphics-line-color* color))

(define (set-drawing-mode! mode)
  (graphics-set-drawing-mode mode)
  (set! *graphics-drawing-mode* mode))

(define (with-color color thunk)
  (let ((old-color))
    (dynamic-wind 
     (lambda ()
       (set! old-color (set! *graphics-line-color* color))
       (graphics-set-line-color *graphics-line-color*))
     thunk
     (lambda ()
       (set! *graphics-line-color* (set! old-color color))
       (graphics-set-line-color *graphics-line-color*)))))

(define (with-style style thunk)
  (let ((old-style))
    (dynamic-wind 
     (lambda ()
       (set! old-style (set! *graphics-line-style* style))
       (graphics-set-line-style *graphics-line-style*))
     thunk
     (lambda ()
       (set! *graphics-line-style* (set! old-style style))
       (graphics-set-line-style *graphics-line-style*)))))

(define (with-mode mode thunk)
  (let ((old-mode))
    (dynamic-wind 
     (lambda ()
       (set! old-mode (set! *graphics-drawing-mode* mode))
       (graphics-set-drawing-mode *graphics-drawing-mode*))
     thunk
     (lambda ()
       (set! *graphics-drawing-mode* (set! old-mode mode))
       (graphics-set-drawing-mode *graphics-drawing-mode*)))))

\f


;;; Character Stuff

(define *graphics-character-slant* 0)
(define *graphics-character-rotation* 0)
(define *graphics-character-size* 50)
(define *graphics-character-aspect* 0.7)

(define (set-default-character-attributes!)
  (set! *graphics-character-slant* 0)
  (set! *graphics-character-rotation* 0)
  (set! *graphics-character-size* 50)
  (set! *graphics-character-aspect* 0.7)
  (reset-character-attributes!))

(define (reset-character-attributes!)
  (graphics-set-letter *graphics-character-size*
		       *graphics-character-aspect*
		       *graphics-character-slant*)
  (graphics-set-rotation *graphics-character-rotation*))

(define (set-character-attributes! #!optional size rotation aspect slant)
  (if (not (unassigned? size))
      (set! *graphics-character-size* size))
  (if (not (unassigned? aspect))
      (set! *graphics-character-aspect* aspect))
  (if (not (unassigned? slant))
      (set! *graphics-character-slant* slant))
  (if (not (unassigned? rotation))
      (set! *graphics-character-rotation* rotation))
  #!TRUE)

(define (graphics-text text #!optional size rotation aspect slant)
  (if (unassigned? size)
      (set! size *graphics-character-size*))
  (if (unassigned? aspect)
      (set! aspect *graphics-character-aspect*))
  (if (unassigned? slant)
      (set! slant *graphics-character-slant*))
  (if (unassigned? rotation)
      (set! rotation *graphics-character-rotation*))
  (with-character-attributes size rotation aspect slant
    (lambda ()
      (graphics-label text))))

(define (with-character-attributes size rotation aspect slant thunk)
  (let ((old-size) (old-rot) (old-aspect) (old-slant))
    (dynamic-wind
     (lambda ()
       (set! old-size (set! *graphics-character-size* size))
       (set! old-rot (set! *graphics-character-rotation* rotation))
       (set! old-aspect (set! *graphics-character-aspect* aspect))
       (set! old-slant (set! *graphics-character-slant* slant))
       (graphics-set-letter *graphics-character-size*
			    *graphics-character-aspect*
			    *graphics-character-slant*)
       (graphics-set-rotation *graphics-character-rotation*))
     thunk
     (lambda ()
       (set! *graphics-character-size* (set! old-size size))
       (set! *graphics-character-rotation* (set! old-rot rotation))
       (set! *graphics-character-aspect* (set! old-aspect aspect))
       (set! *graphics-character-slant* (set! old-slant slant))
       (graphics-set-letter *graphics-character-size* 
			    *graphics-character-aspect*
			    *graphics-character-slant*)
       (graphics-set-rotation *graphics-character-rotation*)))))

\f


;;; End Bobcat Graphics Package
))

(set! with-color (access with-color graphics-package))
(set! with-style (access with-style graphics-package))
(set! with-mode (access with-mode graphics-package))
(set! graphics-text (access graphics-text graphics-package))
(set! init-graphics (access init-graphics graphics-package))
(set! clear-graphics (access clear-graphics graphics-package))
(set! draw-line-to (access graphics-line graphics-package))
(set! position-pen (access graphics-move graphics-package))
(set! draw-circle (access graphics-circle graphics-package))
(set! draw-point (access draw-point graphics-package))
(set! clear-point (access clear-point graphics-package))
(set! with-color (access with-color graphics-package))
(set! with-style (access with-style graphics-package))
(set! with-mode (access with-mode graphics-package))
(set! graphics-text (access graphics-text graphics-package))