The following is the source code for the CL Slideshow program, circa version 0.5:
-------------------------------------------------;; =========================================================================== ;; Filename: slideshow.lisp ;; Description: A simple GUI interface for viewing .gif and .jpeg images ;; Author: An Anglican Seminarian <Marlow4@yahoo.com> ;; ;; LICENSES: The contents of this file are GPL'd, visit www.gnu.org ;; if you did not receive a copy of the license with this file. ;; This file makes use of lisp2wish.lisp which is copyrighted by its ;; author but is free for public use, see that file for details. ;; loop.lisp is also used, copyright MIT, free for all uses, see that file. ;; The function PARTITION is not my own but was posted on USENET and CLiki ;; and is public domain. ;; Date: Begun Dec 2001 ;; ;; =========================================================================== ;; ;; To run just type (load "slideshow.lisp") at the LISP prompt; ;; comment out the last line of this file if you don't want it to auto-run ;; ;; To understand how the code works, start from the RUN-MAIN function at the ;; end; it is based on the TEST-WISH function from lisp2wish.lisp ;; ;; =========================================================================== ;; Requirements: ;; --A LISP compiler/interpreter, obviously. ;; This has been tested and works on: ;; > Allegro 6.0 (trial) CASE-INSENSITIVE ;; > CLISP ;; > GCL ;; There's no reason the others shouldn't work with a little tinkering ;; but I haven't gotten very far with that yet. ;; --M. Lindner's lisp2wish file from CLiki (under graphics) ;; --Tcl/Tk's WIndowing SHell (tested on 8.3+) ;; --The IMG package for Tcl/TK for jpegs. ;; (included with the ActiveTcl from scriptics.com, which ;; I recommend since it can be quite a pain to compile) ;; *You can run CL Slideshow with just vanilla wish if you ;; just want to see how it works, but without IMG only ;; .gifs are viewable. ;; NB This has only been tested on Linux, but should run on any UNIX and ;; be portable to Windows with a little tinkering and Macintosh with ;; somewhat more tinkering, since LISP and Tcl/TK are availiable on these ;; platforms. ;; ;; =========================================================================== ;; ;; PORTABILITY NOTES: ;; --- GCL --- ;; --GCL support is now working but may be somewhat buggy. ;; ;; --- CMUCL --- ;; --CMUCL hangs when invoking wish, probably a simple RUN-PROGRAM issue. ;; (I haven't looked into it) ;; ;; --- LISPWORKS --- ;; --(Personal Edition) just hangs when I try to load it, no idea why. ;; (Haven't looked into it at all) ;; ;; --- ALL OTHERS --- ;; I'm afraid I only own five Common LISP compilers, so no others have ;; been tried. ;; ;; === VARIA ;; LISP has been written in all caps to make it easy to tell apart from ;; Tcl--also for that cool retro 70's look! ;; Load MIT loop.lisp if using an implementation without ANSI LOOP #+GCL (LOAD "./loop.lisp") ;; Load M. Lindner's lisp2wish (compiled if you have it) ;; --most people probably don't so I'll comment this out for now. ; #-(OR CLISP ALLEGRO) (LOAD "./lisp2wish.lisp") ; #+ALLEGRO (LOAD "./lisp2wish.fasl") ; #+CLISP (LOAD "./lisp2wish.fas") #-GCL (LOAD "./lisp2wish-jc") #+GCL (LOAD "./lisp2wish-jc.lisp") (MAKE-PACKAGE :SLIDES :USE '(:USER #-GCL :COMMON-LISP #+GCL :LISP :SYSTEM :USER :WISH #+ALLEGRO :EXCL)) (IN-PACKAGE :SLIDES) ;; You'll probably want to change this to where you keep most of your pictures (DEFPARAMETER *DIRECTORY* "~/") (DEFVAR *SLIDES* '()) (DEFVAR *HT* (MAKE-HASH-TABLE)) (DEFVAR *TOTAL-SLIDES* 0) (DEFVAR *CURRENT-IDX* 1) (DEFVAR *CURRENT-SLIDE* NIL) (DEFUN SET-CURRENT () "Gets the filename string for *CURRENT-IDX* from the hash table *HT*" (SETQ *CURRENT-SLIDE* (GETHASH *CURRENT-IDX* *HT*))) ;; The following functions have been discontinued as it is easier ;; to simply call "glob" in Tcl than to try it it LISP. ;; (too many case-sensitivity issues in UNIX). ;(DEFUN LS (DIR) ; #+:CLISP (RUN-SHELL-COMMAND ; (CONCATENATE 'STRING ; "ls " ; DIR ; "*.jpg *.jpeg *.gif") ; :OUTPUT :STREAM) ; #+:ALLEGRO (RUN-SHELL-COMMAND ; (CONCATENATE ; 'STRING ; "ls " ; DIR ; "*.jpg") ; :OUTPUT :STREAM ; :WAIT NIL)) ; ;(DEFUN DIRECTORY-LIST (DIR) ; (LET ((LST '())) ; (WITH-OPEN-STREAM ; (S (MAKE-TWO-WAY-STREAM (LS DIR) ; (MAKE-STRING-OUTPUT-STREAM))) ; (LOOP ; (LET ((ITEM (READ S NIL NIL))) ; ;(WRITE ITEM) ; (when (NULL ITEM) ; (RETURN LST)) ; (SETQ LST (CONS ITEM LST))))))) ;; This function taken from the "partition" post on Cliki ;; It would be nice if there were some way to make this go ;; on GCL... (DEFUN PARTITION (DELIMITER SEQ &KEY (MAXIMUM NIL) (REMOVE-EMPTY-SUBSEQS NIL) (FROM-END NIL) (START 0) (END NIL) (TEST NIL TEST-SUPPLIED) (TEST-NOT NIL TEST-NOT-SUPPLIED) (KEY NIL KEY-SUPPLIED)) "Return a list of subsequences in seq delimited by delimiter. If :remove-empty-subseqs is true, empty subsequences will be discarded from the result; otherwise they will be included. If :maximum is supplied, the result will contain no more than :maximum possibly empty subsequences. The second result value contains the unsplit rest of the sequence. All other keywords work analogously to those for CL:POSITION." ;; DO: Make keep-delimiters include the dennlimiters in the result(?). (LET ((LEN (LENGTH SEQ))) (UNLESS END (SETQ END LEN)) ;; DO: Find a more efficient way to take care of :from-end T. (WHEN FROM-END (SETF SEQ (REVERSE SEQ)) (PSETF START (- LEN END) END (- LEN START))) (LOOP WITH OTHER-KEYS = (NCONC (WHEN TEST-SUPPLIED (LIST :TEST TEST)) (WHEN TEST-NOT-SUPPLIED (LIST :TEST-NOT TEST-NOT)) (WHEN KEY-SUPPLIED (LIST :KEY KEY))) FOR LEFT = START THEN (+ RIGHT 1) FOR RIGHT = (MIN (OR (APPLY #'POSITION DELIMITER SEQ :START LEFT OTHER-KEYS) LEN) END) UNLESS (AND (= RIGHT LEFT) ; empty-subsequence REMOVE-EMPTY-SUBSEQS) IF (AND MAXIMUM (>= NR-ELTS MAXIMUM)) ;; We can't take any more. Return now. RETURN (VALUES SUBSEQS (SUBSEQ SEQ LEFT END)) ELSE COLLECT (SUBSEQ SEQ LEFT RIGHT) INTO SUBSEQS AND SUM 1 INTO NR-ELTS UNTIL (= RIGHT END) FINALLY (RETURN (VALUES SUBSEQS (SUBSEQ SEQ RIGHT END)))))) (DEFUN DIRECTORY-LIST (DIR) "Queries tcl for a directory's (string DIR) files" (DECLARE (STRING DIR)) (PARTITION #\SPACE (STRING-RIGHT-TRIM '(#\NEWLINE) (SEND-TO-WISH (FORMAT NIL "puts [glob ~A*.jpg *.gif *.jpeg]~%" DIR) :WAIT-FOR-ANSWER T)))) ; (LOOP FOR STR = (SEND-TO-WISH ; (FORMAT NIL "puts [exec ls ~A];~%" DIR) ; :WAIT-FOR-ANSWER T) ; WHILE (SEARCH "error" STR) ; FINALLY (RETURN STR)))) (DEFUN POPULATE-SLIDES (DIR) "Performs the necessary operations to set up the global variables in order to run a slideshow in the directory DIR" (SETQ *SLIDES* '()) ;(FORMAT T "~A~%" (DIRECTORY-LIST DIR))) (SETQ *HT* (MAKE-HASH-TABLE)) (SETQ *SLIDES* (SORT (FILTER-IMAGES (DIRECTORY-LIST DIR)) #'STRING-LESSP)) (SETQ *TOTAL-SLIDES* (LENGTH *SLIDES*)) (HASH-FILL *HT* *SLIDES*) (SETQ *CURRENT-IDX* 0)) (DEFUN HASH-FILL (HASH LST) "Fills a hash with a list, using keys starting at 1" (DECLARE (HASH-TABLE HASH) (LIST LST)) (labels ((FILLER (N THING LEN) (IF (>= N LEN) (SETF (GETHASH N HASH) (CAR LST)) (PROGN (SETF (GETHASH N HASH) THING) (SETQ LST (CDR LST)) (FILLER (+ N 1) (CAR LST) LEN))))) (FILLER 1 (CAR LST) (LENGTH LST)))) ;; If you don't have IMG in your wish distribition, ;; remove all mention of jpegs in this function. (DEFUN FILTER-IMAGES (WHOLE-LIST) "Takes a list of the files in a directory in string form and returns a list of only the images (gif and jpeg)" (DELETE-IF-NOT #'(LAMBDA (X) (AND (OR (SEARCH ".jpg" X) (SEARCH ".gif" X) (SEARCH ".jpeg" X)) (NOT (OR (SEARCH "*" X) ;; appears in negative ;; result messages ;; Bogus responses also appear with these: (NOT (SEARCH *DIRECTORY* X)) (SEARCH (STRING #\NEWLINE) X))))) WHOLE-LIST)) (DEFUN SHOW-NEW-BITMAP (INAME) "Displays the image described in the INAME string" (DECLARE (STRING INAME)) (WHEN (NULL INAME) (SETQ INAME "nil")) ;or else allegro chokes (WHEN (OPEN (PARSE-NAMESTRING INAME) :IF-DOES-NOT-EXIST NIL) ; (FORMAT T "~A~3A~%" INAME (STRINGP INAME)) ; (FORMAT T "~@R~%" *CURRENT-IDX*) (FORMAT *WISH* "wm title . {CL SlideShow: ~A}~% ~ .f.c delete all~% ~ image delete $im~% ~ set im [image create photo -file ~S -height 1100 -width 1400];~% ~ .f.c create image 0 0 -image $im -anchor nw -tag ~S~%" INAME INAME INAME) (SETQ *CURRENT-SLIDE* INAME))) ;; WARNING this will crash the program if you attempt to double the ;; size of a file too big for your memory to handle! (Silly Tcl) (DEFUN RESIZE-IMAGE (&KEY GROW) "Resizes the currently-displayed image, either doubling it or halving it in size according to :GROW" (DECLARE (BOOLEAN GROW)) (LET ((OP (IF GROW "-zoom 2 2" "-shrink -subsample 2 2"))) (FORMAT *WISH* ".f.c delete all ~% ~ set im2 [image create photo]~% ~ $im2 copy $im ~A~% ~ image delete $im~% ~ set im $im2~% ~ .f.c create image 0 0 -image $im -anchor nw~%" OP))) (DEFUN CHANGE-PATH () "Queries the user for a new directory and sets up a slideshow in the directory returned." (LET ((FULLPATH (STRING-RIGHT-TRIM (STRING #\NEWLINE) (SEND-TO-WISH (FORMAT NIL "puts [tk_chooseDirectory -initialdir ~A]~%" *DIRECTORY*) :WAIT-FOR-ANSWER T)))) ;(FORMAT T "Fullpath is ~A~%" FULLPATH) (UNLESS (STRING= "" FULLPATH) (SETQ *DIRECTORY* (CONCATENATE 'STRING FULLPATH "/")) ;(FORMAT T "*DIRECTORY* IS ~A~%" *DIRECTORY*) (POPULATE-SLIDES *DIRECTORY*)))) (DEFUN PREV-SLIDE () "Displays the previous slide, loops if at end" (DECF *CURRENT-IDX*) (WHEN (EQL *CURRENT-IDX* 0) (SETQ *CURRENT-IDX* *TOTAL-SLIDES*)) (SHOW-NEW-BITMAP (GETHASH *CURRENT-IDX* *HT*))) (DEFUN NEXT-SLIDE () "Displays the next slide, loops if at end" (INCF *CURRENT-IDX*) (WHEN (> *CURRENT-IDX* *TOTAL-SLIDES*) (SETQ *CURRENT-IDX* 1)) (SHOW-NEW-BITMAP (GETHASH *CURRENT-IDX* *HT*))) (SETQ *RANDOM-STATE* (MAKE-RANDOM-STATE T)) (DEFUN RANDOM-NEXT () "Displays another slide at random" (LET ((IDX (+ (RANDOM *TOTAL-SLIDES*) 1))) (SHOW-NEW-BITMAP (GETHASH IDX *HT*)) (SETQ *CURRENT-IDX* IDX))) ;; (DEFUN DISABLE-CHECK () ;; (IF (> *CURRENT-IDX* *TOTAL-SLIDES*) ;; (SETQ *CURRENT-IDX* 1) ;; (when (EQL *TOTAL-SLIDES* 0) ;; (FORMAT *WISH* ".bNext -command {}~%") ;; (FORMAT *WISH* ".bRandom -command {}~%")))) (DEFUN TIMED-SHOW (&OPTIONAL (INTERVAL 5) &KEY (RAND T) &AUX (DONE NIL)) "Displays slides automatically at fixed intervals" (DECLARE (INTEGER INTERVAL) (BOOLEAN RAND) (BOOLEAN DONE)) (LOOP ;; WITH isn't in GCL, which I want to make at least SOME effort to support ;; since it is still the ONLY free lisp that lets you make small binary ;; executables. (LET ((IDX (IF RAND (+ (RANDOM *TOTAL-SLIDES*) 1) *CURRENT-IDX*))) (WHEN DONE (RETURN NIL)) (PROGN (SHOW-NEW-BITMAP (GETHASH IDX *HT*)) (SETQ *CURRENT-IDX* (+ IDX 1)) (DOTIMES (X (* INTERVAL 4)) (WHEN (STRING= (STRING-RIGHT-TRIM (STRING #\NEWLINE) (SEND-TO-WISH (FORMAT NIL "puts $timedShow~%") :WAIT-FOR-ANSWER T)) "0") (SETQ DONE T) (RETURN NIL)) (SLEEP 0.1)))))) (DEFUN MAKE-BUTTON (NAME &OPTIONAL CALLBACK &KEY (FRAME ".f1")) "Sends a button constructor to wish, callback is optional only as shorthand--it MUST be provided if the button label is more than one word, or if you want to have more than one button with the same label that you want to have call different functions." (DECLARE (STRING FRAME) (STRING NAME) (STRING CALLBACK)) (WHEN (NULL CALLBACK) (SETQ CALLBACK NAME)) (FORMAT *WISH* "button ~A.b~A -text {~A} -command {set timedShow 0;puts ~A}~%" FRAME CALLBACK NAME CALLBACK) (FORMAT *WISH* "pack ~A.b~A -side left~%" FRAME CALLBACK)) ;; This function simply mimics TEST-WISH from Lindner's lisp2wish.lisp ;; with the framework for this app plugged in. (DEFUN RUN-MAIN () "Starts and runs the app CL Slideshow" (WITH-WISH (WITH-OUTPUT-TO-WISH (FORMAT T "Handshaking ...") (FORMAT *WISH* "puts {OK};flush stdout~%") #-(OR ALLEGRO LUCID) (FORCE-OUTPUT *WISH*) #+(OR ALLEGRO LUCID) (MULTIPLE-VALUE-BIND (RET ERR) (IGNORE-ERRORS (FORCE-OUTPUT *WISH*)) (UNLESS RET (FORMAT t "SLIDES-WISH:WARNING: ~ Could not flush *wish-stream* during handshake!~%"))) (LET ((R (READ-LINE *WISH* NIL "SLIDES-WISH: No message from wish!"))) (UNLESS (STRING-EQUAL "OK" R) #-CMU (CLOSE-PROCESS-STREAM *WISH*) (SETQ *WISH* NIL) (RETURN-FROM RUN-MAIN R))) (FORMAT T " ok.~%") (FORMAT T "Initializing ...") ;; ------------------------------------------------------------------ ;; ;; PUT YOUR MAIN TCL/TK FRAMEWORK HERE ;; (Then close up to WITH-OUTPUT-TO-WISH) ;; ;; The Img extension is required for .jpeg files, otherwise ;; remove the first part of this quotation. (FORMAT *WISH* "package require Img~% ~ wm title . {CL SlideShow};~% ~ frame .f1~% ~ pack .f1~% ~ set timedShow 0~%") (dolist (N '("Prev" "Next" "Shrink" "Grow" "Random" "Auto" "Load" "Rename" "Delete" "Quit")) (MAKE-BUTTON N)) (POPULATE-SLIDES *DIRECTORY*) (NEXT-SLIDE) (FORMAT *WISH* "set im [image create photo -file ~S -height 1100 -width 1400];~%" *CURRENT-SLIDE*) (FORMAT *WISH* "frame .f -bd 2;~% ~ pack .f -fill both -expand 1~% ~ scrollbar .f.scv -command \".f.c yview\";~% ~ scrollbar .sch -orient horizontal \ ~ -command \".f.c xview\" ~% ~ canvas .f.c -relief sunken \ ~ -width 900 -height 600 \ ~ -scrollregion {0 0 1100 1400} \ ~ -xscrollcommand \".sch set\" \ ~ -yscrollcommand \".f.scv set\";~% ~ pack .f.c -in .f -side left -fill both -expand 1~% ~ pack .f.scv -in .f -side right -fill y~% ~ pack .sch -side top -fill x -expand 1~%") (FORMAT *WISH* ".f.c create image 0 0 -image $im -anchor nw -tag ~S~%" *CURRENT-SLIDE*)) ;; ------------------------------------------------------------------- (FORMAT T " done.~%") (FORMAT T "Listening: ~%") (LISTEN-TO-WISH #'(LAMBDA (STRING) (FORMAT T "WISH sayeth: ~A" STRING) ;; ;; HANDLE EVENTS HERE ;; (CASE (INTERN (STRING-UPCASE ;; Chomp and add symbol to package (STRING-RIGHT-TRIM (STRING #\NEWLINE) STRING)) "SLIDES") (SHRINK (RESIZE-IMAGE :GROW NIL) NIL) (GROW (RESIZE-IMAGE :GROW T) NIL) (NEXT (NEXT-SLIDE) NIL) (PREV (PREV-SLIDE) NIL) (RANDOM (RANDOM-NEXT) NIL) (AUTO (PROGN (FORMAT *WISH* "set timedShow 1~%") (TIMED-SHOW 6) NIL)) (LOAD (CHANGE-PATH) ;(FORMAT T "~S~%" *DIRECTORY*) NIL) (RENAME (SEND-TO-WISH (FORMAT NIL "tk_dialog .wn {Sorry.} ~ {This has not yet been implimented} ~ {} {} OK~%")) NIL) (DELETE (SEND-TO-WISH (FORMAT NIL "tk_dialog .wn {Sorry.} ~ {This has not yet been implimented} ~ {} {} OK~%")) NIL) (QUIT (ZEROP (READ-FROM-STRING (SEND-TO-WISH (FORMAT NIL "puts [tk_dialog .tw {Really Quit?} ~ {Are you sure you want to quit?} ~ {} {} Ok Cancel]~%") :WAIT-FOR-ANSWER T)))) (OTHERWISE (FORMAT *ERROR-OUTPUT* "D'oh! Funky message from wish: ~S~%" STRING) NIL)))) (FORMAT T "Quitting ...")) (FORMAT T "Done~%") 'OK) ;; For easy execution, comment out if you prefer to call it from LISP. ;; It's left out by default for GCL since with GCL you can make a ;; standalone executable so autorunning the function isn't so useful. ;; (you do that by 'compile-file'ing lisp2wish.lisp, loop.lisp, and ;; slideshow.lisp; then load the three *.o files, then type ;; (si:save-system "slideshow") and there you have your binary executable). #-GCL (RUN-MAIN) #+GCL (DEFUN SI:TOP-LEVEL () (RUN-MAIN))