Beginner's question about accept

[Gunter Albers <alberts%cui.unige.ch@RELAY.CS.NET>]

This is an example which shows how one could use icons.
(It's not great code I know!)
Now I have the problem that I don't know how to inhibit "accept"
to print back an accepted value to window where it is read.
(in the function do-it)        Any ideas ?
I do not want to modify sys:print or the presentation type.

;;; -*- Mode: LISP; Syntax: Common-lisp; Package: Cl-User; Base: 10 -*-

(defvar *fenster*  nil             "the gem window")
(defvar exit-char  (char-code #\a) "exit icon")    
(defvar exit-do    nil             "the real exit" )
(defvar trash-char (char-code #\u) "trash can icon")
(defvar trashcan   nil             "the real trash can")
(defvar file-char  (char-code #\n) "file icon")
(defvar *font*     nil             "this is the icon font")

(defun  flip-char  (x y code)
  "draws an icon"
  (graphics:draw-glyph code *font* x y :stream *fenster* :alu :flip))
 
(defflavor icon (code presentation x y) ()
  :initable-instance-variables
  :writable-instance-variables)

(defmethod (sys:print-self icon)
	   (stream ignore ignore)
  (format stream "CHAR:~A, ~A ~A " code x y))

;; not really necessary
(define-presentation-type icon (())
   :no-deftype t
   :parser ((stream) (loop (dw:read-char-for-accept stream)))
   ;; I don't want to use this trick
   ;; :printer ((icon stream) ..... )
   )

(defun present-icon (some-icon)
  (setf (icon-presentation some-icon)
	(dw:with-output-as-presentation (:stream *fenster*
					 :object some-icon
				         :type  'icon)
	  (flip-char (icon-x some-icon) (icon-y some-icon) (icon-code some-icon
))))
  some-icon)

(defun  make-icon  (x y code)
  (present-icon (make-instance 'icon :x x :y y :code code)))

(defun  copy-icon  (some-icon)
  (make-icon (icon-x some-icon) (icon-y some-icon) (icon-code some-icon)))

(defun  erase-icon (some-icon)
  (flip-char (icon-x some-icon) (icon-y some-icon) (icon-code some-icon))
  (send *fenster* :delete-displayed-presentation (icon-presentation some-icon)))

(defun  match-icons-p (icon1 icon2)
  (and (< -10 (- (icon-x icon1) (icon-x icon2)) 10)
       (< -10 (- (icon-y icon1) (icon-y icon2)) 10)))

(defun init ()
  "Clears the GEM window and displays the icons"
  (send *fenster* :select)		 
  (send *fenster* :clear-history)
  ;; for items on the top-row, e.g. things representing files
  (dotimes (i 4)   (make-icon (* i 100) 100 file-char))
  ;; trash can bottom left
  (setq trashcan   (make-icon 200       300 trash-char))
  (setq exit-do    (make-icon 300       300 exit-char)))

(defun do-it ()
  "This function runs GEM with an infite loop"
  (send *fenster* :select)
  (loop
    for some-icon = (accept 'icon :stream *fenster* :prompt nil)
    do (unwind-protect
	   (progn
	     ;; we first erase this icon
	     (erase-icon some-icon)
	     (dw:tracking-mouse (*fenster*)
	       ;; if the mouse is moved, don't do anything and restart
	       (:mouse-motion (ignore ignore) (return t))
	       ;; if mouse is held move the object
	       (:mouse-motion-hold (x y)
		;; draw the icon at this place
		(flip-char x y (icon-code some-icon))
		(when (match-icons-p some-icon trashcan) (beep))
		(sleep 0.05)
		;; erase it after a while and remember the position
		(flip-char x y (icon-code some-icon))
		(setf (icon-x some-icon) x)
		(setf (icon-y some-icon) y))
	       (:keyboard (char) (cond ((char-equal char #\e) (return t))
				       ((char-equal char #\c) (copy-icon some-icon))))))
	 ;; exit if icon is exit icon
	 (if (equal some-icon exit-do)
	     (progn
	       (send *fenster* :deselect)
	       (return-from do-it "yeah you managed to escape!!!")))
	 ;; the icon is "presented" once we stop drawing, unless it is in the trash
	 (unless (and (match-icons-p some-icon trashcan)
		      (neq           some-icon trashcan))
	   (present-icon some-icon)  )
	 )))

(defun gem-init ()
  "For setting up the pseudo-gem example"
  (setq *fenster* (tv:make-window 'dw:dynamic-window :edges-from :mouse))
  ;; reads in a font file with real icons
  ;; (setq *font* (fed:read-font-from-bfd-file "peps:sys;icons"))
  (setq *font* fonts:mouse)
  (gem))

(defun gem ()
  "Calls and executes pseudo-GEM"
  (init)
  (do-it)
  )