[LISP] programs (11)

1 Name: #!/usr/bin/anonymous : 2009-04-14 14:18 ID:VD9IJuBK

Here's an image viewer I recently wrote, in common lisp.
You'll need lispbuilder-sdl and lispbuilder-sdl-image for this, also com.gigamonkeys.pathnames. All the source of PCL here, http://gigamonkeys.com/book/practicals-1.0.3.tar.gz

esc escapes the viewer
space views the next image, backspace the previous. If there's no other image to show, the program exits.
You can invoke VIEW with both a single image to view or a directory to be searched recursively and show the images.
Example, (view "/path/to/pictures"), (view "/path/to/pictures/foo.jpg")

(defparameter *supported-formats* '(".bmp" ".jpg" ".png"))
(defun list-to-array (list)
(and (listp list)
(make-array (list (list-length list))
:initial-contents list)))
(defun valid-image-p (p)
(and (stringp p)
(> (length p) 3)
(member (string-downcase (subseq p (- (length p) 4)))
*supported-formats* :test #'string=)))
(defun show-image (p s)
(sdl:clear-display (sdl:color :r 0 :g 0 :b 0) :surface s)
(sdl:draw-surface (sdl-image:load-image p) :surface s)
(sdl:update-display s))
(defun list-load-images (file)
(if (valid-image-p file)
(list file)
(remove-if-not #'valid-image-p
(mapcar #'namestring (list-directory file)))))
(defun array-load-images (file)
(list-to-array (list-load-images file)))
(defun view-image (p s e)
(show-image p s)
(let ((rv e))
(sdl:with-events ()
(:quit-event () t)
(:key-down-event (:key key)
(cond ((sdl:key= key :sdl-key-space)
(setf rv 1)
(sdl:push-quit-event))
((sdl:key= key :sdl-key-backspace)
(setf rv -1)
(sdl:push-quit-event))
((sdl:key= key :sdl-key-escape)
(sdl:push-quit-event))))
(:video-expose-event (sdl:update-display s)))
rv))
(defun view (file)
(sdl:with-init ()
(let* ((p (array-load-images file))
(plen (length p))
(surface (sdl:window 0 0)))
(unless p (error "no image/s"))
(loop for i = 0 then (+ i (view-image (aref p i) surface plen))
while (and (>= i 0) (< i plen))))))

2 Name: dmpk2k!hinhT6kz2E : 2009-04-15 20:45 ID:Heaven

You'll have a hard time convincing people to install SBCL. :o

3 Name: #!/usr/bin/anonymous : 2009-04-18 22:44 ID:rqqdcJqO

>>2
Which people? I've got it installed already, as do several people I know.

4 Name: #!/usr/bin/anonymous : 2009-04-19 05:16 ID:Heaven

> Which people?

people who don't fantasize about oatmeal with toenail clippings in it.

5 Name: dmpk2k!hinhT6kz2E : 2009-04-19 08:01 ID:Heaven

I feel a bit bad about >>2. I'm actually happy to see some variety in code.

Common Lisp spooks me due to its sheer size though. If only Scheme had a useful set of mature libraries.

Unrelated aside: it seems Factor has first-class macros. How does that work?

6 Name: Zach Beane : 2009-04-20 12:07 ID:SikWUUwZ

(coerce list 'vector) is a shorter way to do list-to-array.

The one-letter variable names are hard to follow.

7 Name: OP : 2009-04-21 02:32 ID:VPLCSXs5

>>6
Thanks, I'm still at the first learning steps. COERCE seems to be the abstraction I was in need but unaware of.

As for the one-letter names, I agree. It's how I write code because I don't want to waste time thinking for a name when the code to-be-written is at hand. When the code portion is done, I take time to rename the symbols, but in this particular instance I was so excited from my first lisp program that I shared the source omitting this step.

8 Name: #!/usr/bin/anonymous : 2009-04-24 17:01 ID:0LdgJMma

OP again

This is a simple drawing program.
You can either draw in a white canvas or on top of an image of your choice. Use (draw) or (draw "/path/to/foo.png") for example.

It has 7 colors, red, orange, yellow, green, blue, indigo, violet. You can change color with spacebar, save your drawing with s (which will either save to file lisp.bmp if you were drawing on a white canvas else /path/to/foo.png.bmp) and exit with escape.

(defparameter *supported-formats* '(BMP JPG PNG))
(defparameter *color-pallete*
(circular-list
(mapcar (lambda (x) (apply #'sdl:color x))
'((:r #16rff :g #16r00 :b #16r00) ; red
(:r #16rff :g #16ra5 :b #16r00) ; orange
(:r #16rff :g #16rff :b #16r00) ; yellow
(:r #16r00 :g #16r80 :b #16r00) ; green
(:r #16r00 :g #16r00 :b #16rff) ; blue
(:r #16r4b :g #16r00 :b #16r82) ; indigo
(:r #16ree :g #16r82 :b #16ree))))) ; violet

(defun circular-list (lst)
(let ((new (copy-list lst)))
(if new (setf (cdr (last new)) new))))

(defun draw (&optional file)
(sdl:with-init ()
(sdl:window 0 0)
(setf (sdl:frame-rate) 30)
(if file
(sdl:draw-surface (sdl-image:load-image file))
(sdl:clear-display (sdl:color :r 255 :g 255 :b 255)))
(sdl:update-display)
(sdl:with-events ()
(:quit-event () t)
(:video-expose-event () (sdl:update-display))
(:key-down-event (:key key)
(cond ((sdl:key= key :sdl-key-escape)
(sdl:push-quit-event))
((sdl:key= key :sdl-key-space)
(pop *color-pallete*))
((sdl:key= key :sdl-key-s)
(sdl:save-image sdl:*default-display*
(if file (concatenate 'string file ".bmp") "lisp.bmp")))))
(:mouse-motion-event (:state state :x x :y y :x-rel xrel :y-rel yrel)
(when (= 1 state)
(sdl:draw-line-* x y (- x xrel) (- y yrel)
:color (car *color-pallete

9 Name: #!/usr/bin/anonymous : 2009-04-24 17:04 ID:0LdgJMma

*))
(sdl:update-display))))))

These were missing from the source I posted. Append them to what's been posted already.

10 Name: Zach Beane : 2009-04-27 15:30 ID:SikWUUwZ

CL has special syntax for bits, octal, and hex, and #r is the escape hatch for other bases. So instead of #16rFF, I'd write #xFF. You could also write it as #b11111111 or #o377 but that would be silly...

11 Name: #!/usr/bin/anonymous : 2009-04-27 17:29 ID:eloEXY0+

>>10
Ah, that's better.

There's something else I realized, the implementation of circular-list can be simplified:

(defun circular-list (lst)
(let ((lst (copy-list lst)))
(if lst (nconc lst lst))))

and if the WHEN-BIND macro is available, (on lisp), it could be written even sorter.

Your website has a lot of lisp code, cool. :-) Once I feel more comfortable with my lisp knowledge and I've read some more chapters from the book I mentioned before, I think I'm going to start reading others' code, so your website will come handy.

This thread has been closed. You cannot post in this thread any longer.