;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license.  By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;; 
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;; 
;;; Copyright 1995 by the Massachusetts Institute of Technology.  All
;;; rights reserved.  Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;; 
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED.  By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;; 
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software.  Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;; 

(in-package 2dg)

(export '(*image-size-x* *image-size-y* *CONVEX-DOT-RATE* DISPLAY-OBJECT? DISPLAY-BOUNDING-BOX DISPLAY-OBJECT-POINTS
	  WITH-OUTPUT-INTO-BITMAP DISPLAY-OBJECT-TO-ARRAY DISPLAY-AREA-TO-ARRAY DISPLAY-STRING-TO-ARRAY
	  DISPLAY-LINE-SEGMENT-TO-ARRAY DISPLAY-STRIP-TO-ARRAY DISPLAY-EXTREMA-TO-ARRAY DISPLAY-CONVEX-GROUP-TO-ARRAY
	  DISPLAY-DISTINGUISHED-POINTS-TO-ARRAY
	  AVERAGE-POINTS DISPLAY-OBJECT? DISPLAY-BOUNDING-BOX PRINT-TRAITS CLASSIFY-TRAIT TRAIT-TYPE-LESS?
	  TRAITS-MEET-UNARY-CONSTRAINT? TRAIT-TYPES-MEET-UNARY-CONSTRAINT? PRINT-CONVEX-GROUPS RECTANGLE-LINE-SEGMENTS
	  PRINT-COMBINED-CONVEX-GROUPS COLLECT-SEPARATE-CONVEX-GROUPS COLLECT-SEPARATE-CONVEX-GROUPS-NON-RECURSIVE
	  PRINT-ORDERED-CONVEX-GROUPS
	  PRINT-COMBINED-TRAITS PADDED-DISPLAY-BOUNDING-BOX DISPLAY-BOUNDING-BOX-LIST COLLECT-SEPARATE-TRAITS
	  PRINT-TRAIT-LIST DOTTED-EDGE-IMAGE MY-PS-HARDCOPY-1-BIT-RASTER))

(defvar *image-size-x* 646)
(defvar *image-size-y* 486)
(defvar *CONVEX-DOT-RATE* 3)
(defvar *DISPLAY-CORNER-WIDTH* 5)

(defun DISPLAY-OBJECT? (object)
  (or (geometric-object? object)
      (list-of-points? object)
      (extrema-p object)
      (strip? object)
      (area? object)
      (tline-p object)
      (convex-group-p object)))

(defun DISPLAY-BOUNDING-BOX (obj)
  "Just like Bounding-Box, but can handle strings of points too."
  (cond ((geometric-object? obj) (bounding-box obj))
	((tline-p obj)
	 (bounding-box (tline-to-segment obj)))
	((list-of-points? obj)
	 (loop for point in obj
	       as x = (point-x point)
	       as y = (point-y point)
	       with min-x = most-positive-single-float
	       with max-x = most-negative-single-float
	       with min-y = most-positive-single-float
	       with max-y = most-negative-single-float
	       do
	   (when (> x max-x) (setf max-x x))
	   (when (< x min-x) (setf min-x x))
	   (when (> y max-y) (setf max-y y))
	   (when (< y min-y) (setf min-y y))
	       finally
		 (return (make-rectangle min-x max-x min-y max-y))))
	((area? obj)
	 (make-rectangle (area-min-x obj) (area-max-x obj) (area-min-y obj) (area-max-y obj)))
	((extrema-p obj)
	 (make-rectangle (point-x (extrema-point obj)) (point-y (extrema-point obj))
			 (point-x (extrema-point obj)) (point-y (extrema-point obj))))
	((strip? obj)
	 (display-bounding-box (strip-points obj)))
	((convex-group-p obj)
	 (display-bounding-box (append (loop for cl in (convex-group-lines obj)
					     appending
					       (list (c-line-point-1 cl)
						     (c-line-point-2 cl)))
				       (if (eq (convex-group-corners obj) :uncomputed)
					   nil
					   (loop for corner in (convex-group-corners obj)
						 for pt = (convex-corner-point corner)
						 collect (make-point (+ (point-x pt) *display-corner-width*)
								     (+ (point-y pt) *display-corner-width*))
						 collect (make-point (- (point-x pt) *display-corner-width*)
								     (- (point-y pt) *display-corner-width*)))))))))
	       

(defun DISPLAY-OBJECT-POINTS (obj)
  (cond ((list-of-points? obj) obj)
	((point-p obj) (list obj))
	((line-segment-p obj) (points-between (line-segment-point-1 obj) (line-segment-point-2 obj)))
	((area? obj) (area-display-points obj))
	((extrema-p obj) (list (extrema-point obj)))
	((strip? obj) (strip-display-points obj))
	((convex-group-p obj) (convex-group-display-points obj))))

"
(defmacro WITH-OUTPUT-INTO-BITMAP (args &rest body)
  (let ((bm (car args)))
    `(multiple-value-bind (bitmap x0 y0 xend yend)
	 ,(append `(graphics:with-output-to-bitmap ())
		  body)
       ;; If x0-var is negative or greater than max-width, it means we want to draw outside the image.
       ;; If x0-var < 0, we want to bitblt to 0, cutting off the front of the bitmap-var.
       (let* ((x-start	(if (< x0 0) 0 x0))	; Place in bm we bitblt to
	      (x-stop (if (<= *image-size-x* xend) (1- *image-size-x*) xend))
	      (y-start	(if (< y0 0) 0 y0))			
	      (y-stop (if (<= *image-size-y* yend) (1- *image-size-y*) yend))
	      (bit-x-start (- x-start x0))	; Place in bitmap we start bitblting from
	      (bit-y-start (- y-start y0))
	      (width (- x-stop x-start))
	      (height (- y-stop y-start)))
	 (if (/= width 0)
	     ;; If there were no graphic output commands, bitmap will be a 0x0 array
	     (bitblt tv:alu-ior width height bitmap bit-x-start bit-y-start ,bm x-start y-start)
	     ,bm)))))
"

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Display Routines

(defun DISPLAY-OBJECT-TO-ARRAY (obj array)
;  (let ((stream (dw:get-program-pane rex::'curve-display-pane)))
;    (dw:with-output-as-presentation (:stream stream :type 'symbol :object name)
;      (graphics:with-room-for-graphics (t 0)
    (ecase (geometric-type obj)
      (2dg::line-segment (display-line-segment-to-array obj array))
      (2dg::tline (display-line-segment-to-array (tline-to-segment obj) array))
      (2dg::string (display-string-to-array obj array))
      (2dg::strip (display-strip-to-array obj array))
      (2dg::area (display-area-to-array obj array))
      (2dg::convex-group (display-convex-group-to-array obj array))
      (2dg::extrema (display-extrema-to-array obj array))))
;))
;  )

(defun DISPLAY-AREA-TO-ARRAY (area array &optional (gray (multiple-value-bind (n frac)
						    (floor (sqrt (norm (car (area-points area)))))
						  (ignore n)
						  (* .7 frac))))
  nil)
"
  (let ((a (make-array (list *image-size-y* *image-size-x*) :element-type '(unsigned-byte 1)))
	(max-x 0)
	(max-y 0)
	(min-x *image-size-x*)
	(min-y *image-size-y*))
    (loop for pt in (area-points area)
	  doing
      (setf (aref a (point-y pt) (point-x pt)) 1)
      (setf max-x (max max-x (point-x pt)))
      (setf max-y (max max-y (point-y pt)))
      (setf min-x (min min-x (point-x pt)))
      (setf min-y (min min-y (point-y pt))))
    (with-output-into-bitmap (array)
	  (graphics:draw-rectangle min-x min-y max-x max-y :mask a :gray-level gray))))
"

(defun DISPLAY-STRING-TO-ARRAY (string array)
  (loop for pt in (string-points string)
	doing
    (setf (aref array (point-y pt) (point-x pt)) 1)))

(defun DISPLAY-LINE-SEGMENT-TO-ARRAY (ls array &key check-bounds?)
  (multiple-value-bind (max-x max-y)
      (values-list (array-dimensions array))
    (loop for pt in (points-between (line-segment-point-1 ls) (line-segment-point-2 ls))
	  for x = (point-x pt)
	  for y = (point-y pt)
	  doing
      (when (or (not check-bounds?)
		(and (<= 0 x) (<= 0 y) (< x max-x) (< y max-y)))
	(setf (aref array (point-y pt) (point-x pt)) 1)))))

(defun DISPLAY-STRIP-TO-ARRAY (strip array)
  (loop for pt in (mapcar #'angle-point-point (strip-angle-points strip))
	doing
    (setf (aref array (point-y pt) (point-x pt)) 1))
  (loop for mp in (strip-matching-points strip)
	doing
    (let ((pt1 (strip-matching-point-point mp))
	  (pt2 (angle-point-point (nth (strip-matching-point-number mp)
				       (strip-angle-points strip)))))
      (loop for pt in (points-between pt1 pt2)
	    doing
	(setf (aref array (point-y pt) (point-x pt)) 1)))))

(defun DISPLAY-EXTREMA-TO-ARRAY (extrema array)
  nil)
"
  (with-output-into-bitmap (array)
			   (let* ((point (extrema-point extrema))
				  (scale (extrema-scale extrema))
				  (size (cond ((< scale 5) 4)
					      ((< scale 10) 6)
					      ((< scale 20) 8)
					      (t 10))))    
			     (if (extrema-type-max? extrema)
				 (graphics:draw-circle (point-x point) (point-y point) size :filled nil)
				 (let ((x (point-x point))
				       (y (point-y point)))
				   (graphics:draw-rectangle (- x size) (- y size) (+ x size) (+ y size) :filled nil))))))
"

(defun DISPLAY-CONVEX-GROUP-TO-ARRAY (cg array)
  (when (convex-group-lines cg)
    ;; Not a "mock" convex group, that just has corner points.
    (let* ((midpoints (loop for l in (convex-group-lines cg)
			    collecting
			      (average-points (list (c-line-point-1 l) (c-line-point-2 l))))) 
	   (midpoint (average-points midpoints)))
      (loop for ls in (convex-group-line-segments cg)
	    doing
	(display-line-segment-to-array ls array))
      (loop for mp in midpoints
	    doing
	(loop for pt in (points-between (round-point midpoint) (round-point mp))
	      for i from 1
	      doing
	  (when (= 0 (mod i *CONVEX-DOT-RATE*))
	    (setf (aref array (point-y pt) (point-x pt)) 1))))))
  (when (not (eq (convex-group-corners cg) :uncomputed))
    (display-distinguished-points-to-array (mapcar #'convex-corner-point (convex-group-corners cg)) array)))

(defun DISPLAY-DISTINGUISHED-POINTS-TO-ARRAY (pts array &optional (type 0))
  nil)
"
  (with-output-into-bitmap (array)
			   (ecase type
			     (0
			       (loop for pt in pts
				     doing
				 (graphics:draw-circle (round (point-x pt))
						       (round (point-y pt))
						       *display-corner-width*
						       :filled nil)))
			     (1
			       (loop for pt in pts
				     for x = (point-x pt)
				     for y = (point-y pt)
				     doing
				 (graphics:draw-rectangle (- x *display-corner-width*)
							  (- y *display-corner-width*)
							  (+ x *display-corner-width*)
							  (+ y *display-corner-width*)
							  :filled nil))))))
"

(defun AVERAGE-POINTS (pts)
  (loop for i from 0
	for pt in pts
	sum (point-x pt) into x
	sum (point-y pt) into y
	finally (return (make-point (float (/ x i)) (float (/ y i))))))

(defun PRINT-TRAITS (traits strings name &optional (printer "pravda"))
  nil)
"
  (let ((raster (make-array (list *image-size-y* *image-size-x*) :element-type '(unsigned-byte 1))))
    (loop for string in strings
	  doing
      (display-object-to-array string raster))
    (loop for ext in (append (nth 7 traits) (nth 9 traits))
	  doing
      (display-object-to-array ext raster))
    (user::ps-hardcopy-1-bit-raster raster printer :title (string-append name " extrema") :zoom 4)
    (bitblt tv:alu-setz *image-size-x* *image-size-y* raster 0 0 raster 0 0)
    (loop for strip in (nth 5 traits)
	  doing
      (display-object-to-array strip raster))
    (loop for line in (nth 1 traits)
	  doing
      (display-object-to-array line raster))
    (user::ps-hardcopy-1-bit-raster raster printer :title (string-append name " strips/lines") :zoom 4)
    (bitblt tv:alu-setz *image-size-x* *image-size-y* raster 0 0 raster 0 0)
    (loop for string in strings
	  doing
      (display-object-to-array string raster))
    (loop for area in (nth 3 traits)
	  doing
      (display-object-to-array area raster))
    (user::ps-hardcopy-1-bit-raster raster printer :title (string-append name " areas") :zoom 4)))
"

(defun CLASSIFY-TRAIT (trait)
  (geometric-type trait))

(defun TRAIT-TYPE-LESS? (type1 type2)
  (geometric-type-less? type1 type2))

(defun TRAITS-MEET-UNARY-CONSTRAINT? (trait1 trait2)
  (eq (classify-trait trait1) (classify-trait trait2)))

(defun TRAIT-TYPES-MEET-UNARY-CONSTRAINT? (type1 type2)
  (eq type1 type2))

(defun PRINT-CONVEX-GROUPS (cgs &key name (printer "pravda")
			    (raster (make-array (list *image-size-y* *image-size-x*) :element-type 'bit))
			    print-cover-pages)
  nil)
"
  (loop for cg in cgs
	doing
    (display-object-to-array cg raster)
    (loop for c-line in (convex-group-lines cg)
	  for ls = (c-line-segment c-line)
	  doing
      (display-object-to-array ls raster))
    (let ((bb (padded-display-bounding-box cg)))
      (loop for ls in (rectangle-line-segments bb)
	    doing
	(display-object-to-array ls raster))))
  (my-ps-hardcopy-1-bit-raster raster printer :title (string-append name " convex groups") :zoom 4
			       :print-cover-pages print-cover-pages))
"

(defun ARRAY-CONVEX-GROUPS (cgs &key (raster (make-array (list *image-size-y* *image-size-x*) 
                                                         :element-type 'bit)))
  (loop for cg in cgs
	doing
    (display-object-to-array cg raster)
    (loop for c-line in (convex-group-lines cg)
	  for ls = (c-line-segment c-line)
	  doing
      (display-object-to-array ls raster))
    (let ((bb (padded-display-bounding-box cg)))
      (loop for ls in (rectangle-line-segments bb)
	    doing
	(display-object-to-array ls raster))))
  raster)

(defun file-CONVEX-GROUPS (cgs name raster)
  (loop for cg in cgs
	doing
    (display-object-to-array cg raster)
    (loop for c-line in (convex-group-lines cg)
	  for ls = (c-line-segment c-line)
	  doing
      (display-object-to-array ls raster))
    (let ((bb (padded-display-bounding-box cg)))
      (loop for ls in (rectangle-line-segments bb)
	    doing
	(display-object-to-array ls raster))))
  (user::ps-file-1-bit-raster raster name :zoom 4))

(defun RECTANGLE-LINE-SEGMENTS (r)
  (list
    (make-line-segment (make-point (rectangle-min-x r) (rectangle-min-y r))
		       (make-point (rectangle-max-x r) (rectangle-min-y r)))
    (make-line-segment (make-point (rectangle-max-x r) (rectangle-max-y r))
		       (make-point (rectangle-max-x r) (rectangle-min-y r)))
    (make-line-segment (make-point (rectangle-max-x r) (rectangle-max-y r))
		       (make-point (rectangle-min-x r) (rectangle-max-y r)))
    (make-line-segment (make-point (rectangle-min-x r) (rectangle-min-y r))
		       (make-point (rectangle-min-x r) (rectangle-max-y r)))))

(defun PRINT-COMBINED-CONVEX-GROUPS (cgs &optional name (printer "pravda") background-mask (number-to-print 100)
				     print-cover-pages)
  (loop for print-collection in (collect-separate-convex-groups-non-recursive cgs)
					      ; nil nil (mapcar #'padded-display-bounding-box cgs) nil nil)
	for print-num from 1 to number-to-print
	doing
    (print-convex-groups print-collection :name (string-append name (format nil " ~A" print-num)) :printer printer
			 :raster (if background-mask (copy-array background-mask) nil)
			 :print-cover-pages print-cover-pages)))

(defun ARRAY-COMBINED-CONVEX-GROUPS (cgs &optional background-mask (number-to-print 100))
  (loop for print-collection in (collect-separate-convex-groups-non-recursive cgs)
        repeat number-to-print
	collecting
    (array-convex-groups print-collection
			 :raster (if background-mask (copy-array background-mask) nil))))

(defun FILE-COMBINED-CONVEX-GROUPS (cgs file background-mask &optional (number-to-print 100))
  (loop for print-collection in (collect-separate-convex-groups-non-recursive cgs)
					      ; nil nil (mapcar #'padded-display-bounding-box cgs) nil nil)
	for print-num from 1 to number-to-print
	doing
    (file-convex-groups print-collection (string-append file (format nil "-~A.ps" print-num)) (copy-array background-mask))))
  

(defun PRINT-ORDERED-CONVEX-GROUPS (cgs &optional name (printer "pravda") background-mask (number-to-print 100)
				     print-cover-pages)
  (loop for print-collection in (mapcar #'list cgs)
					      ; nil nil (mapcar #'padded-display-bounding-box cgs) nil nil)
	for print-num from 1 to number-to-print
	doing
    (print-convex-groups print-collection :name (string-append name (format nil " ~A" print-num)) :printer printer
			 :raster (if background-mask (copy-array background-mask) nil)
			 :print-cover-pages print-cover-pages)))

(defun COLLECT-SEPARATE-CONVEX-GROUPS (cgs-to-go &optional print-collection excess
				       (bbs-to-go (mapcar #'padded-display-bounding-box cgs-to-go)) print-bbs excess-bbs answer)
  (flet ((bb-intersects (bb bbs)
	   (loop for bb2 in bbs thereis (intersect? bb bb2))))
    (if (null cgs-to-go)
	(if (null excess) (reverse (cons print-collection answer))
	    (collect-separate-convex-groups excess nil nil excess-bbs nil nil (cons print-collection answer)))
	(if (bb-intersects (car bbs-to-go) print-bbs)
	    (collect-separate-convex-groups (cdr cgs-to-go) print-collection (cons (car cgs-to-go) excess)
					    (cdr bbs-to-go) print-bbs (cons (car bbs-to-go) excess-bbs) answer)
	    (collect-separate-convex-groups (cdr cgs-to-go) (cons (car cgs-to-go) print-collection) excess
					    (cdr bbs-to-go) (cons (car bbs-to-go) print-bbs) excess-bbs answer)))))

(defun COLLECT-SEPARATE-CONVEX-GROUPS-non-recursive (cgs-to-go &optional (pad 4))
  (flet ((bb-intersects (bb bbs)
	   (loop for bb2 in bbs thereis (intersect? bb bb2))))
    (loop with bbs-to-go = (loop for cg in cgs-to-go collect (padded-display-bounding-box cg pad))
	  with print-collection = nil
	  with excess = nil
	  with print-bbs = nil
	  with excess-bbs = nil
	  with answer = nil
	  until (and (null cgs-to-go) (null excess))
	  finally (return (reverse (cons print-collection answer)))
	  doing
      (if (null cgs-to-go)
	  (setq cgs-to-go excess
		answer (cons print-collection answer)
		print-collection nil
		excess nil
		bbs-to-go excess-bbs
		print-bbs nil
		excess-bbs nil)
	  (if (bb-intersects (car bbs-to-go) print-bbs)
	      (setq excess (cons (car cgs-to-go) excess)
		    cgs-to-go (cdr cgs-to-go)
		    excess-bbs (cons (car bbs-to-go) excess-bbs)
		    bbs-to-go (cdr bbs-to-go))
	      (setq print-collection (cons (car cgs-to-go) print-collection)
		    cgs-to-go (cdr cgs-to-go)
		    print-bbs (cons (car bbs-to-go) print-bbs)
		    bbs-to-go (cdr bbs-to-go)))))))

(defun PRINT-COMBINED-TRAITS (traits &optional name (printer "pravda"))
  (loop for print-collection in (collect-separate-traits traits nil nil (mapcar #'display-bounding-box-list traits) nil nil)
	for print-num from 1
	doing
    (print-trait-list print-collection (string-append name (format nil " ~A" print-num)) printer)))

(defun PADDED-DISPLAY-BOUNDING-BOX (trait &optional (pad 4))
  (let ((rect (display-bounding-box trait)))
    (make-rectangle (max 0 (- (rectangle-min-x rect) pad))
		    (min (1- *image-size-x*) (+ (rectangle-max-x rect) pad))
		    (max 0 (- (rectangle-min-y rect) pad))
		    (min (1- *image-size-y*) (+ (rectangle-max-y rect) pad)))))

(defun DISPLAY-BOUNDING-BOX-LIST (traits)
  (let ((bbs (loop for trait in traits collecting (display-bounding-box trait))))
    (loop for bb in (cdr bbs)
	  with min-x = (rectangle-min-x (car bbs))
	  with min-y = (rectangle-min-y (car bbs))
	  with max-x = (rectangle-max-x (car bbs))
	  with max-y = (rectangle-max-y (car bbs))
	  doing
      (setq min-x (min min-x (rectangle-min-x bb))
	    min-y (min min-y (rectangle-min-y bb))
	    max-x (max max-x (rectangle-max-x bb))
	    max-y (max max-y (rectangle-max-y bb)))
      finally (return (make-rectangle min-x max-x min-y max-y)))))

(defun COLLECT-SEPARATE-TRAITS (traits-to-go &optional print-collection excess
				       (bbs-to-go (mapcar #'display-bounding-box-list traits-to-go)) print-bbs excess-bbs answer)
  (flet ((bb-intersects (bb bbs)
	   (loop for bb2 in bbs thereis (intersect? bb bb2))))
    (if (null traits-to-go)
	(if (null excess) (reverse (cons print-collection answer))
	    (collect-separate-traits excess nil nil excess-bbs nil nil (cons print-collection answer)))
	(if (bb-intersects (car bbs-to-go) print-bbs)
	    (collect-separate-traits (cdr traits-to-go) print-collection (cons (car traits-to-go) excess)
					    (cdr bbs-to-go) print-bbs (cons (car bbs-to-go) excess-bbs) answer)
	    (collect-separate-traits (cdr traits-to-go) (append (car traits-to-go) print-collection) excess
					    (cdr bbs-to-go) (cons (car bbs-to-go) print-bbs) excess-bbs answer)))))


(defun PRINT-TRAIT-LIST (traits &optional name (printer "pravda")
			    (raster (make-array (list *image-size-y* *image-size-x*) :element-type 'bit)))
  nil)
"
  (loop for trait in traits
	doing
    (display-object-to-array trait raster))
  (my-ps-hardcopy-1-bit-raster raster printer :title name ; (string-append name " traits")
			       :zoom 4))
"

(defun DOTTED-EDGE-IMAGE (edges dot-rate)
  (let ((strings (edge-image-strings edges))
	(raster (make-array (list *image-size-y* *image-size-x*) :element-type 'bit
                            :initial-element 0)))
    (loop for string in strings
	  finally (return raster)
	  doing
      (loop for pt in string
	    for i from 0
	    doing
	(when (= 0 (mod i dot-rate))
	  (setf (aref raster (point-y pt) (point-x pt)) 1))))))

(defun MY-PS-HARDCOPY-1-BIT-RASTER (raster printer
				 &key (zoom 1) (position :center) (landscape-mode t)
				 (title "1 Bit Raster Hardcopy")
				 (print-cover-pages t))
  nil)
"
  (multiple-value-bind (width height) (decode-raster-array raster)
    (with-open-stream
      (hc-stream (hardcopy:make-hardcopy-stream
		   (hardcopy:get-hardcopy-device printer)
		   :landscape-p landscape-mode
		   :print-cover-pages print-cover-pages
		   :title title ))
      (send hc-stream :set-allow-draw-outside-of-bounding-box t)
      (multiple-value-bind (p-width p-height) (send hc-stream :inside-size)
	(setq p-width (send hc-stream :convert-from-device-units p-width :pixel :horizontal))
	(setq p-height (send hc-stream :convert-from-device-units p-height :pixel :vertical))
	(let ((left (user::conv-to-dev hc-stream
				 (if (eql position :center)
				     (floor (- p-width (* zoom width)) 2)
				     (first position))
				 :x))
	      (top (user::conv-to-dev hc-stream
				(if (eql position :center)
				    (- p-height (floor (- p-height (* zoom height)) 2))
				    (second position) )
				:y )))
	  (send hc-stream :string-out title)
	  (send hc-stream :show-bitmap
		raster width height :left left :top top :hzoom zoom :vzoom zoom))
	))))
"
