From: Christopher William Bowron
Subject: displaying image in clx
Date: 
Message-ID: <lxbsndgv23k.fsf@tarsal.cse.msu.edu>
I am working on a project where i am reading in a file in ppm format
(ASCII) and trying to write a program to display the image... I have
it working for monochrome images ("P1") but i am having trouble
getting the color version ("P3") to work... My main problem lies in
trying to get the colors from the colormap...

I get errors on alloc-color so i think i am probably doing something
wrong... I don't know if i have to create a new colormap and install
and use that instead or what...

any help is appreciate... if you have code that displays any type of
image using clx i would appreciate looking at that... here is what i
have: 


;;; Christopher Bowron <········@cse.msu.edu>

;;; draw a bitmap

(use-package :xlib)

(eval-when (:compile-toplevel :load-toplevel)
  (require 'color-bitmap))

(cond
 ((string-equal "CMU Common Lisp" (lisp-implementation-type))
  (defun getenv (var)
    (cdr (assoc (intern var :keyword) *environment-list*))))
 ((string-equal "CLISP" (lisp-implementation-type))
  (defun getenv (var)
    (system::getenv var)))
 (t
  (error "Unknown LISP Implementation")))
  
(defun strip-colon (str)
  (let ((p (position #\: str)))
    (if p
	(subseq str 0 p)
      str)))

(defun get-host ()
  (let* ((display (strip-colon (getenv "DISPLAY"))))
    (if (and display (not (string-equal display "")))
	display
      "127.0.0.1"
      )))

;; some special variables to hold display and window info
(defvar *window*)
(defvar *gcontext*)
(defvar *colormap*)
(defvar *screen*)
(defvar *display* nil)
(defvar *black*)
(defvar *white*)
(defvar *bm*)

(defparameter *width* 320)
(defparameter *height* 200)

(defun set-pixel (x y color)
  (let ((fg (alloc-color *colormap* color)))
    (with-gcontext (*gcontext* :foreground fg)
		   (draw-point *window* *gcontext* x y))))

(defun set-pixel-index (x y pixel-index)
  (with-gcontext (*gcontext* :foreground pixel-index)
		 (draw-point *window* *gcontext* x y)))

(defun set-pixel-mono (x y i max)
  (declare (ignore max))
  (when (not (zerop i))
    (set-pixel-index x y *white*)))
  
(defun set-pixel-gray (x y i max)
  (declare (ignore max))
  (when (not (zerop i))
    (set-pixel-index x y *white*)))

(defun set-pixel-color (x y i max)
  (let ((red (coerce (/ (rgb-red i) max) 'float))
	(blue (coerce (/ (rgb-blue i) max) 'float))
	(green (coerce (/ (rgb-green i) max) 'float)))
    (set-pixel x y (make-color :red red :green green :blue blue))))

(defun display-bitmap (bm)
  (let* ((max (bitmap-max bm))
	 (magic (bitmap-magic bm))
	 (pixel-routine
	  (cond ((string-equal magic "P1") #'set-pixel-mono)
		((string-equal magic "P2") #'set-pixel-gray)
		((string-equal magic "P3") #'set-pixel-color)
		(t nil))))
    (do ((x 0 (+ 1 x)))
	((>= x (bitmap-width bm)) nil)
      (do ((y 0 (+ 1 y)))
	  ((>= y (bitmap-height bm)) nil)
	(let ((i (aref (bitmap-data bm) x y)))
	  (funcall pixel-routine x y i max))))))

(defun do-graphics ()
  (clear-area *window*)
  (display-bitmap *bm*))
      
;;; main function... 
(defun draw-bitmap (bitmap-file)
  (let ((abort t)
	(host (get-host))
	(x 100)
	(y 100)
	(display-count 0)
	(font "fixed"))
    (setq *bm* (read-pbm bitmap-file))
    (unwind-protect
	(progn 
	  (setq *display* (open-display host))
	  (setq *screen* (display-default-screen *display*))
	  (multiple-value-prog1
	   
	   (let* ((black (screen-black-pixel *screen*))
		  (white (screen-white-pixel *screen*))
		  (font (open-font *display* font)))
	     
	     (setq *black* black)
	     (setq *white* white)

	     (setq *width* (bitmap-width *bm*))
	     (setq *height* (bitmap-height *bm*))

	     (setq *colormap* 
		    (screen-default-colormap *screen*))
	      (setq *window* 
		    (create-window :parent (screen-root *screen*)
				   :x x :y y
				   :width *width* :height *height*
				   :background black
				   :border white
				   :border-width 1
				   :colormap *colormap*
				   :bit-gravity :center
				   :event-mask '(:exposure :button-press)))
	      (setq *gcontext* 
		    (create-gcontext :drawable *window*
				     :background black
				     :foreground white
				     :font font))

	      ;; Set window manager hints
	      (set-wm-properties *window*
				 :name bitmap-file
				 :resource-class 'hello-world
				 :command (list* 'hello-world host nil)
				 :x x :y y 
				 :width *width* :height *height*
				 :min-width *width* :min-height *height*
				 :input :off :initial-state :normal)

	      (map-window *window*)		; Map the *window*
	      
	      ;; Handle events
	      (event-case (*display* :discard-p t :force-output-p t)
			  (exposure  ;; Come here on exposure events
			   (window count)
			   (when (eq *window* window)
			     (format t "COUNT = ~A~%" count)
			     (when (zerop count)
			       (when (zerop display-count)
				 (do-graphics))
			       (incf display-count))
			     ;; Returning non-nil causes event-case to exit
			     nil))
			  
			  (button-press () t)))  ;; Pressing any mouse-button exits
	   
	   (setq abort nil)))
      
      ;; Ensure display is closed when done
      (when *display*
	(close-display *display* :abort abort)))))

;;; Christopher Bowron <········@cse.msu.edu>

;;; functions and structures for bitmaps...

(provide 'color-bitmap)

(defparameter *verbose* t)

(defstruct rgb
  (red  0 :type fixnum)
  (blue 0 :type fixnum)
  (green 0 :type fixnum))

(defstruct bitmap
  (magic "" :type string)
  (width 0 :type fixnum)
  (height 0 :type fixnum)
  (data nil :type t)
  (max 255 :type fixnum))

(defun make-color-pixmap (width height)
  (make-array (list width height)
	      :initial-element nil))

(defun make-gray-pixmap (width height)
  (make-array (list width height)
	      :initial-element 0))

(defun read-color-pixels (file width height)
  (let ((w 0)
	(h 0)
	(i 0)
	(r 0)
	(g 0)
	(b 0)
	(pixmap (make-color-pixmap width height)))
    (do ((str (read-line file nil nil)
	      (read-line file nil nil)))
	((null str) pixmap)
	;; skip comments
	(unless (eq (aref str 0) #\#)
	  (let ((str-input (make-string-input-stream str)))
	    (do ((value (read str-input nil nil)
			(read str-input nil nil)))
		((null value))
	      (case i
		(0 (setq r value))
		(1 (setq g value))
		(2 (setq b value)))
	      (incf i)
	      (when (>= i 3)
		(setf (aref pixmap w h) (make-rgb :red r :green g :blue b))
		(setq i 0)
		(incf w)
		(when (>= w width)
		  (setq w 0)
		  (incf h)))))))))

(defun read-gray-pixels (file width height)
  (let ((w 0)
	(h 0)
	(pixmap (make-color-pixmap width height)))
    (do ((str (read-line file nil nil)
	      (read-line file nil nil)))
	((null str) pixmap)
	;; skip comments
	(unless (eq (aref str 0) #\#)
	  (let ((str-input (make-string-input-stream str)))
	    (do ((value (read str-input nil nil)
			(read str-input nil nil)))
		((null value))
	      (setf (aref pixmap w h) value)
	      (incf w)
	      (when (>= w width)
		(setq w 0)
		(incf h))))))))
	
(defun read-pbm (filename)
  (let ((count 0)
	(magic "")
	(w 0)
	(h 0)
	(max 0))
    (with-open-file (input filename :direction :input)
		    (do ((str (read-line input nil nil)
			      (read-line input nil nil)))
			((null str) nil)
		      (if (eq (aref str 0) #\#)
			  (when *verbose* (format t "COMMENT ~A~%" str))
			(let ((str-input (make-string-input-stream str)))
			  (do ((value (read str-input nil nil)
				      (read str-input nil nil)))
			      ((null value))
			    (incf count)
			    (case count
			      (1
			       (setq magic (symbol-name value))
			       (when *verbose*
				 (format t "MAGIC: ~A~%" magic)))
			      (2
			       (setq w value)
			       (when *verbose*
				 (format t "WIDTH: ~A~%" w)))
			      (3
			       (setq h value)
			       (when *verbose*
				 (format t "HEIGHT: ~A~%" h))
			       (when (string-equal magic "P1")
				 (return-from read-pbm
				   (make-bitmap :magic magic
						:width w
						:height h
						:max max
						:data
						(read-gray-pixels input
								  w h)))))
			      (4 (setq max value)
				 (when *verbose*
				   (format t "MAX: ~A~%" max))
				 (return-from read-pbm
				   (make-bitmap :magic magic
						:width w
						:height h
						:max max
						:data
						(read-color-pixels input
								   w h))))))))))))



-- 
(setq sig '((Christopher Bowron)
	    (········@cps.msu.edu)
	    (www.cse.msu.edu/~bowronch)
	    ("we came, we saw, we got bored and left")))
From: Marco Antoniotti
Subject: Re: displaying image in clx
Date: 
Message-ID: <y6cofnoc0c5.fsf@octagon.mrl.nyu.edu>
Christopher William Bowron <········@tarsal.cse.msu.edu> writes:

> (cond
>  ((string-equal "CMU Common Lisp" (lisp-implementation-type))
>   (defun getenv (var)
>     (cdr (assoc (intern var :keyword) *environment-list*))))
>  ((string-equal "CLISP" (lisp-implementation-type))
>   (defun getenv (var)
>     (system::getenv var)))
>  (t
>   (error "Unknown LISP Implementation")))

The above code is not portable.  Especially if you try to introduce
other implementations.  The above works only because both CMUCL and
CLISP have a "SYSTEM" package, which is not mandated by the standard,
*and* you are USE(ing)-PACKAGE the "EXTENSION" package in CMUCL. The
following is portable, thanks to the read time conditionals.

#+cmu
(defun getenv (var)
  (cdr (assoc (intern var :keyword) *environment-list*))))

#+clisp
(defun getenv (var)
  (system::getenv var)))


In alternative you can separate these functions in separate files like

	impl-dependent/cmucl.lisp
	impl-dependent/clisp.lisp

With each function in each file.  If you want a rather general
machinery to achieve these effects (always using the "separate files approach")
you can look at CL-ENVIRONMENT in the CLOCC (the CVS version is more
up to date.)

Cheers

-- 
Marco Antoniotti ========================================================
NYU Courant Bioinformatics Group        tel. +1 - 212 - 998 3488
719 Broadway 12th Floor                 fax  +1 - 212 - 995 4122
New York, NY 10003, USA                 http://bioinformatics.cat.nyu.edu
                    "Hello New York! We'll do what we can!"
                           Bill Murray in `Ghostbusters'.
From: Kent M Pitman
Subject: Re: displaying image in clx
Date: 
Message-ID: <sfwlmisfv8j.fsf@world.std.com>
Marco Antoniotti <·······@cs.nyu.edu> writes:

> Christopher William Bowron <········@tarsal.cse.msu.edu> writes:
> 
> > (cond
> >  ((string-equal "CMU Common Lisp" (lisp-implementation-type))
> >   (defun getenv (var)
> >     (cdr (assoc (intern var :keyword) *environment-list*))))
> >  ((string-equal "CLISP" (lisp-implementation-type))
> >   (defun getenv (var)
> >     (system::getenv var)))
> >  (t
> >   (error "Unknown LISP Implementation")))
> 
> The above code is not portable.  Especially if you try to introduce
> other implementations.  The above works only because both CMUCL and
> CLISP have a "SYSTEM" package, which is not mandated by the standard,
> *and* you are USE(ing)-PACKAGE the "EXTENSION" package in CMUCL.

Yeah, you could repair it with (funcall (intern "GETENV" "SYSTEM") var),
of course, but that would be slow. ;-)

> The
> following is portable, thanks to the read time conditionals.
> 
> #+cmu
> (defun getenv (var)
>   (cdr (assoc (intern var :keyword) *environment-list*))))
> 
> #+clisp
> (defun getenv (var)
>   (system::getenv var)))
 
Yes, this is better.

> 
> In alternative you can separate these functions in separate files like [...]

Yes, this is also better.

Yet another alternative is:

 (defun getenv (var)
   (funcall (or #+cmu #'(lambda (var) 
                          (cdr (assoc (intern var :keyword)
				      *environment-list*)))
                #+clisp #'(lambda (var) (system::getenv var))
                #'(lambda (var)
                    (declare (ignore var))
                    (error "~S is not implemented." 'getenv)))))

This has the advantage of making a sort of "else" clause for feature 
fallthrough for a common bug:  Doing 

(defun getenv (var)
  #+cmu   (cdr (assoc (intern var :keyword) *environment-list*))
  #+clisp (system::getenv var)
  #-(or cmu clisp)
    (progn var ;ignored
       (error "~S is not implemented." 'getenv)))

also works but risks that if you add more features, you'll forget to update
the #-(or cmu clisp) pattern to match and get things out of line.
comp.lang.lisp / 2001 / sep