;;;
;;;  Margaret M. Fleck and Daniel E. Stevenson
;;;  copyright 1997
;;;

;;;  Examples using Envision's window graphics and binary file I/O

;;; ================================================================
;;;  File I/O
;;; ================================================================

;;; Read something from a file in Envision's tagged binary format
(define (read-from-file filename)
  (let* ((fp (open-binary-input-file filename))
         (output (binary-read fp)))
   (close-binary-port fp)
   output))

;;; Write something to a file in Envision's tagged binary format
(define (write-to-file object filename)
  (let* ((fp (open-binary-output-file filename)))
    (binary-write object fp)
    (close-binary-port fp)))

;;; Read some sample file data
;;;   m-dog is a manifold
;;;   g-dog is an integer-grid
;;;   bluehouse is a list containing a string and a manifold
(define m-dog (read-from-file "/group/scheme/envision/images/manifold-dog.env"))
(define g-dog (read-from-file "/group/scheme/envision/images/sheet-dog.env"))
(define bluehouse (read-from-file "/group/scheme/envision/images/bluehouse.env"))

;;; ================================================================
;;; Graphics
;;; ================================================================

;;; Open and close a window
(define mywin (open-window "test window" '(-200 200) '(-200 200)))
(close-window mywin)

;;; Get a list of open windows 
(list-windows)

;;; Draw the dog on a window
;;;   (Notice that m-dog and bluehouse won't draw because they aren't
;;;    integer grids.  See image displayer example for how to handle them.)
(draw g-dog mywin (make-point 0 0))

;;; Draw geometrical objects on the window
(define myellipse (make-ellipse (make-point 0 0) 50 30 0 360 (make-point 1 0)))
(draw myellipse mywin (make-point 0 0) '(color 255) '(filled? #t) '(scale 1.0))



;;; ================================================================
;;; The colormap
;;; ================================================================

;;; Display a pattern of square (of the specified width), one for 
;;;    each colormap entry.  A safe sample value for width is 20.
(define (show-colormap width)
   (let* ((window-width (* width 16))
	  (window-range (list 0 window-width))
	  (pattern (make-integer-grid "colormap" 
				      (list 'flat 1 window-range window-range)
				      `(flat 1 (0 255))
				      #f 0))
	  (mywin (open-window "colormap" window-range window-range)))
     (colormap-pattern pattern width)
     (draw pattern mywin (make-point 0 0))))

;;; one square for each color in map
(bulk-define colormap-pattern
	     ((integer-grid 2 1) integer) unspecified
    (lambda (input-grid width)
      (scan (ptr input-grid)
        (let ((location (sample->point ptr)))
	  (sample-set! ptr
		       (+ (quotient (point-coordinate location 0) width)
		         (* 16 (quotient (point-coordinate location 1) width))))))))



;;; ================================================================
;;; Bundles
;;; ================================================================

;;; Draw a strip of hexagons
(define (hex-strip mywin start displacement size number color) 
  (let* ((domain (list 'flat 1 (list 0 (- number 1))))
	 (codomain `(flat 0.1 (-200 200) (-200 200)))
	 (p1 (make-real-grid "test" domain codomain #t))
	 (p2 (make-real-grid "test" domain codomain #t))
	 (p3 (make-real-grid "test" domain codomain #t))
	 (p4 (make-real-grid "test" domain codomain #t))
	 (p5 (make-real-grid "test" domain codomain #t))
	 (p6 (make-real-grid "test" domain codomain #t))
	 (hex (make-polygon p1 p2 p3 p4 p5 p6)))
    (line-of-figures p1 (make-point 1 0) displacement)
    (line-of-figures p2 (make-point 0.5 1) displacement)
    (line-of-figures p3 (make-point -0.5 1) displacement)
    (line-of-figures p4 (make-point -1 0) displacement)
    (line-of-figures p5 (make-point -0.5 -1) displacement)
    (line-of-figures p6 (make-point 0.5 -1) displacement)
    (draw hex mywin start (list 'color color) (list 'scaling size))
    hex))

;;; Fills coordinates for a line of identical figures
(bulk-define line-of-figures 
	     ((real-grid 1 2) (real-point 2) (real-point 2)) unspecified
    (lambda (grid start spacing)
      (let ((newpoint start))
        (scan (ptr grid)
           (sample-set! ptr newpoint)
           (set! newpoint (+ newpoint spacing))))))

;;; ================================================================
;;; Synthetic integer-grid patterns
;;; ================================================================

;;; Some synthetic patterns suitable for drawing on a window.  (Real images
;;;    are manifolds and require a displayer which converts them to integer grids.)

;; a square on a shaded background
(bulk-define square ((integer-grid 2 1) integer integer integer) unspecified
    (lambda (input a b width)
      (scan (ss input) 
         (let* ((point (sample->point ss))
                (point0 (point-coordinate point 0))
                (point1 (point-coordinate point 1)))
          (cond ((and (>= point0 a) (< point0 (+ a width))
                      (>= point1 b) (< point1 (+ b width)))
                 (sample-set! ss 200))
                (#t (sample-set! ss (+ 100 point1))))))))


;;; synthetic ramp pattern
(bulk-define horizontal-ramp 
   ((integer-grid 2 1) integer integer)
   unspecified
   (lambda (input start step)
     (scan (ss input #f scan-right)
	   (scan (kk ss #f scan-up)
		 (sample-set! kk start))
           (set! start (+ start step)))))


;;; synthetic sine wave pattern
;;; (used in Dan's thesis)
(bulk-define sine-wave
   ((integer-grid 2 1) real real real)
   unspecified
   (lambda (input amp period offset)
     (let ((myval 0)
	   (myloc 0.0))
       (scan (ss input #f scan-right)
	     (set! myloc (+ myloc 1))
	     (set! myval 
		   (inexact->exact 
		    (round (+ offset 
			      (* amp (sin (/ (* myloc 2 pi) period)))))))
	     (scan (kk ss #f scan-up)
		   (sample-set! kk myval))))))