;;; -------------------------------------------------------------------- ;;; Title: Acclaim - A Simple Presentation Program ;;; Authors: Daniel Barlow, Max-Gerd Retzlaff ;;; Version: 0.23 ;;; Date of this version: May, 26th 2004, 22:07:23 CEST, ;;; and: Jun, 12th 2004, 00:34:13 CEST ;;; ;;; First version by Daniel Barlow ;;; (see http://www.linux.org.uk/~dan/linux2003/viewer.lisp) ;;; Changes by Max-Gerd Retzlaff ;;; ;;; You need CLX and a modified version of image-reader.lisp of the ;;; Eclipse window manager that you should have gotten with this file. ;;; ;;; A set of slides, you can use for testing, is avaliable at: ;;; http://www.linux.org.uk/~dan/linux2003/ukuug-slides.lisp ;;; ;;; History: ;;; 0.10 - 0.11: page numeration ;;; 0.11 - 0.12: li*, br, *draw-background-image* ;;; 0.12 - 0.13: inline image support (with all test code) ;;; 0.13 - 0.14: inline image support (test code removed) ;;; 0.14 - 0.15: cosmetic changes of the source coded ;;; 0.15 - 0.16: renamed from exhibitionist to acclaim ;;; 0.16 - 0.17: new function load-bg-image ;;; 0.17 - 0.18: only minimal changes ;;; 0.18 - 0.19: - make-element is generic function now. ;;; - Inline images are preloaded if *preload-images* is set. ;;; - The background image (or solid color) is to be defined ;;; in a configure-block of the slide definition file. ;;; - If *slides-pathname* is set to a valid pathname the slides ;;; (and its images) will be loaded as acclaim itself is loaded. ;;; 0.19 - 0.20: - Now you can also specify fonts and their colors in the ;;; configure-blog. Right now it is a crude hack and you ;;; can only define the default font and the element "title". ;;; In the next release I will problably remove the macro ;;; make-render-element=around again, replacing it by the ;;; metaclass-foo I had in a previous version of acclaim. ;;; - Note to toggling of *preload-images*: ;;; Use (load-slides pathname :preload-images nil) to switch ;;; it off and t for enabling, respectively. ;;; 0.20 - 0.21: - New metaclass element-class; the elements have now ;;; class slots for fontname, color, and shift-value ;;; (as well as additional slots for their default values). ;;; The macro make-render-element=around is replaced by ;;; a more generic method that uses the new class slots. ;;; These changes make the code far more complex but ;;; on the other hand the configuration of fonts, colors, ;;; etc. in the slide definition files works smoothly now. ;;; - All variables defining the look of acclaim's output ;;; are now restored before a new slide definition is loaded. ;;; - Inline images can be positioned by :x-align and :y-align. ;;; - A new function (change-host hostname). ;;; 0.21 - 0.22: - new variable *debug-do-not-load-bg-image* ;;; - set *font* in #'load-slides if *display* is bound ;;; - set *last-foil* to 0 in #'restore-defaults ;;; - button-press-event removed; #\Space is enough ;;; 0.22 - 0.23: - line wrapping support ;;; (The code itself is very ugly and the algorithm is ;;; really inefficient but it works (also in some ;;; more complicated situations like some different ;;; font enviroments in one line) and as there is ;;; normally only a handful of lines per slide the ;;; inefficiency is really not a very big problem.) ;;; - Every text that is not in a pre enviroment (or a ;;; subclass of it, i.e. smallpre) is now wrapped. ;;; - Apart from the *offset* the *line-begin* of a new line ;;; of text is now to be remembered, in case that a line ;;; wrap occurs. ;;; -------------------------------------------------------------------- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; package definition (defpackage #:acclaim (:use #:cl) ;;(:require #:xlib #:ppm) ;; only pseudo code.. :( (:export #:start #:go-on #:load-slides #:change-host)) (in-package :acclaim) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; variables you might want to change ;; ;; Set this variable to non-nil if the slides should be loaded directly at load-time: (defvar *slides-pathname* #p"/home/mgr/daten/coding/lisp/acclaim/slides/lisp-ist-toll.slides") ;; #p"/home/mgr/daten/coding/lisp/acclaim/slides/ukuug-slides.lisp") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; metaclass definition and defclass macros (eval-when (:compile-toplevel :load-toplevel :execute) ;; <-- !!! ;; this goes for slightly more than 100 lines! (defmacro read-format (control-string &rest format-arguments) `(read-from-string (format nil ,control-string ,@format-arguments))) (defun create-name (part1 part2) (read-format "~a-~a" part1 part2)) (defmacro def-meta-class (name superclass-name &rest slot-names) `(defclass ,(create-name name "class") (,superclass-name) ,(mapcar (lambda (slotname) (let ((longname (create-name name slotname))) `(,slotname :initarg ,longname :initform nil :accessor ,longname))) (mapcan (lambda (name) (list name (create-name name "default"))) slot-names)))) (def-meta-class element standard-class fontname color shift-value) (defmethod #+sbcl sb-pcl:validate-superclass #-sbcl ccl:validate-superclass ((class element-class) (super #+sbcl sb-pcl::standard-class #-sbcl ccl::standard-class)) t) (defvar *element-classes* nil) (defmacro def-element-class (class-name (&key fontname color shift-value) &rest class-def) `(multiple-value-prog1 (defclass ,class-name ,@class-def (:metaclass element-class)) (unless (position ',class-name *element-classes*) (push ',class-name *element-classes*)) ,@(mapcan (lambda (slotset) (let ((slotname (car slotset)) (value (cadr slotset))) (when value (let ((accessor (create-name 'element slotname))) `((setf (,accessor (find-class ',class-name)) ,value) (setf (,(create-name accessor 'default) (find-class ',class-name)) ,value)))))) `((fontname ,fontname) (color ,color) (shift-value ,shift-value))))) (defmethod print-object ((class element-class) stream) (print-unreadable-object (class stream) (format stream "ELEMENT-CLASS ~a: color: ~a / ~a, shift-value: ~a / ~a~% fontname: ~a / ~a" (class-name class) (element-color class) (element-color-default class) (element-shift-value class) (element-shift-value-default class) (element-fontname class) (element-fontname-default class)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; class definitions (def-element-class element nil () ((content :initarg :content :accessor element-content) (parent :initarg :parent :accessor element-parent))) (def-element-class horizontal-element () (element) ()) (def-element-class i (:fontname "-*-helvetica-medium-o-*-*-*-240-*-*-*-*-*-*") (horizontal-element) ()) (def-element-class tt (:fontname "-*-courier-medium-r-*-*-*-240-*-*-*-*-*-*") (horizontal-element) ()) (def-element-class b (:fontname "-*-helvetica-bold-r-*-*-*-240-*-*-*-*-*-*") (horizontal-element) ()) (def-element-class center nil (horizontal-element) ()) (def-element-class vertical-element nil (element) ()) (def-element-class slide nil (vertical-element) ()) (def-element-class title (:fontname "-*-helvetica-medium-r-*-*-*-480-*-*-*-*-*-*" :color "white" :shift-value #c(0 40)) (vertical-element) ()) (def-element-class ul nil (vertical-element) ()) (def-element-class pre (:fontname "-*-courier-medium-r-*-*-*-240-*-*-*-*-*-*" :color "white") (vertical-element) ()) (def-element-class smallpre (:fontname "-*-courier-medium-r-*-*-*-180-*-*-*-*-*-*" :color "white") (pre) ()) (def-element-class line nil (vertical-element) ()) (def-element-class p nil (vertical-element) ()) (def-element-class li nil (vertical-element) ()) (def-element-class li* nil (vertical-element) ()) (def-element-class br nil (vertical-element) ()) (def-element-class image nil (vertical-element) ((clx-image :initarg :clx-image))) ) ;; <----- !!!!!! ) of (eval-when.. !!!!! ;;;;;;;;;;;;;;;;;;;;;;; ;; Far too many variables.. ;; But normally you do not have to change them: ;; Fonts and colors are now defined in the configure-block of the slide-file, ;; *preload-images* is to be set via (load-slides pathname :preload-images nil), ;; and *host* should be changed via (change-host hostname). (defvar *preload-images* t "t: load images while loading the slides (using load-slides), or nil: load images when they are actually put on the screen (using render-element)") (defvar *host* "") (defvar *default-display-depth* ;; has to be before (defvar *bg-clx-image* ..) (ppm:initialize-host-default-display *host*)) (defvar *show-bg-image* nil) (defvar *default-fontname* "-*-helvetica-medium-r-*-*-*-240-*-*-*-*-*-*") (defvar *default-bg-color* "midnightblue") (defvar *default-fg-color* "yellow") (defvar *default-fontname-default* *default-fontname*) (defvar *default-bg-color-default* *default-bg-color*) (defvar *default-fg-color-default* *default-fg-color*) (defvar *bg-clx-image*) (defvar *bg-image-pixmap*) (defvar *bg-image-gcontext*) (defvar *offset* (complex 0 0)) (defvar *line-begin* 0) (defvar *last-string-skip* nil) (defvar *wrap-lines* t) (defvar *main-x-border* 50) (defvar *main-y-border* 20) (defvar *last-foil* 0) (defvar *slides* nil) (DEFVAR *DISPLAY*) (DEFVAR *SCREEN*) (DEFVAR *SCREEN-width*) (DEFVAR *SCREEN-height*) (DEFVAR *COLORMAP*) (DEFVAR *WIN*) (DEFVAR *FONT*) (DEFVAR *fg-color-gcontext*) (DEFVAR *bg-color-gcontext*) (DEFVAR *foreground-pixel*) (DEFVAR *background-pixel*) ;;;;;;;;;;;;;;;;;;;;;;; ;; debug variables (defvar *debug-boxes* nil) (defvar *debug-do-not-load-bg-image* nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; methods and functions ;;;;;;;;;;;;;;;;;;;;;;; ;;; miscellaneous functions (defun change-host (hostname) "Set the hostname to get output on the default display of a different host computer." (format *trace-output* "Note: If the new host's default display has a different color depth you have to reload the slides.~%") (setf *host* hostname) (setf *default-display-depth* (ppm:initialize-host-default-display *host*))) (defun load-bg-image (filename &optional (images-dir *slides-pathname*)) "loads a pnm file (given by filename) into *bg-clx-image*, filename is relative to images-dir (default *slides-pathname*)" (setf *bg-clx-image* (ppm:load-ppm-into-clx-image_depth (merge-pathnames filename images-dir) *default-display-depth*))) (defun get-font (f) (xlib:open-font *display* f)) (defun colorname-to-color (colorname) (xlib:alloc-color *colormap* (xlib:lookup-color *colormap* colorname))) ;;;;;;;;;;;;;;;;;;;;;;; ;;; render-element methods (defgeneric render-element (e)) (defmethod render-element :around ((element element)) (let* ((element-class (class-of element)) (fontname (element-fontname element-class)) (color (element-color element-class)) (shift-value (or (element-shift-value element-class) #c(0 0))) (*font* (if fontname (get-font fontname) *font*))) ;; (format *trace-output* "element-class: ~a~%" element-class) (if (or fontname color) (xlib:with-gcontext (*fg-color-gcontext* :font *font* :foreground (colorname-to-color (or color *default-fg-color*))) (+ shift-value (call-next-method))) (progn (+ shift-value (call-next-method)))))) (defmethod render-element :around ((element pre)) (let ((*wrap-lines* nil)) (call-next-method))) (defmethod render-element :around ((element vertical-element)) (let ((*line-begin* (realpart *offset*))) (call-next-method))) (defmethod render-element :around ((element br)) (setf *offset* (complex *line-begin* (imagpart *offset*))) (call-next-method)) (defmethod render-element :around ((element t)) ;; (declare (optimize (debug 3))) (let ((before *offset*) (size (call-next-method))) (when (and *debug-boxes* before size) (xlib:draw-rectangle *win* *fg-color-gcontext* (floor (realpart before)) (floor (imagpart before)) (floor (realpart size)) (floor (imagpart size)))) size)) (defmethod render-element ((e center)) (multiple-value-bind (w a d l r ascent descent) (xlib:text-extents *font* (car (element-content e))) (declare (ignore a d l r ascent descent)) (let* ((new-offset (- (/ (- (xlib:drawable-width *win*) w) 2) (realpart *offset*))) (*offset* (+ *offset* new-offset))) (+ new-offset (call-next-method))))) (defmethod render-element ((e string)) (let (i start line (width 0) (height 0) (line-begin (floor (realpart *offset*))) (no-whitespace-magic 0) wrap-occured) (when *wrap-lines* ;; hm, should this also slurp the whitespace following the newline? (setf e (substitute #\Space #\Newline e))) (loop ;; (format *trace-output* "a: start: ~a, i: ~a~%" start i) ;; (force-output) (tagbody loop-start (setf start (if i (1+ i) 0) i (unless *wrap-lines* (position #\Newline e :start (if i (1+ i) 0))) line (subseq e (or start 0) (or i (length e)))) ;; (format *trace-output* "b: start: ~a, i: ~a~%" start i) ;; (force-output) (tagbody make-fit ;; Yes, the performance of this algorithm is _impressive_! (multiple-value-bind (line-width a d l r ascent descent) (xlib:text-extents *font* e :start (or start 0) :end (or i (length e))) (declare (ignore a d l r)) (when (and (> line-width (- *screen-width* line-begin *main-x-border*)) *wrap-lines*) ;; (format *trace-output* "too long: ~a~%" line) ;; (force-output) (setf wrap-occured t) (setf i (position-if (lambda (char) (position char '(#\Space #\Newline #\Tab))) e :start (or start 0) :end (or i (length e)) :from-end t) ;; to do: Do some magic if i is nil. line (subseq e (or start 0) (or i (length e)))) ;; (format *trace-output* "new: ~a~%" line) ;; (force-output) (if i ;; <- This is the formidable magic if the line is ;; too long and it doesn't contain any whitespace. (go make-fit) (progn (setf e (concatenate 'string " " e)) (setf no-whitespace-magic (or *last-string-skip* (+ ascent descent))) (go loop-start)))) (xlib:draw-glyphs *win* *fg-color-gcontext* line-begin (floor (+ height ascent (imagpart *offset*))) line) (setf width line-width ;(max width line-width) height (+ ascent descent height) *last-string-skip* (+ ascent descent) line-begin *line-begin*) (unless i (return)))))) (complex (if wrap-occured ;; subtract original difference of *offset* to *line-begin* (- width (- (realpart *offset*) *line-begin*)) width) (+ height no-whitespace-magic)))) (defmethod render-element ((e element)) (let ((size 0) (*offset* *offset*) (kids (element-content e)) outer-wrap-correction) ;; (pprint kids *trace-output*) (loop (let ((kid (car kids))) (setf kids (cdr kids)) (unless kid (return (+ size (if outer-wrap-correction outer-wrap-correction 0)))) (let ((kid-size (render-element kid))) (when (typep kid 'vertical-element) (setf size (complex (max (realpart size) (realpart kid-size)) (+ (imagpart kid-size) (imagpart size))) *offset* (+ *offset* (complex 0 (imagpart kid-size))))) (when (typep kid 'horizontal-element) (setf size (complex (+ (realpart size) (realpart kid-size)) (max (imagpart kid-size) (imagpart size))) *offset* (+ *offset* (realpart kid-size)))) (when (typep kid 'string) (let ((wrap-correction (if *last-string-skip* (complex 0 (- *last-string-skip*)) 0))) (when *last-string-skip* (if outer-wrap-correction (incf outer-wrap-correction wrap-correction) (setf outer-wrap-correction 0))) (setf *last-string-skip* nil) (setf size (complex (+ (realpart size) (realpart kid-size)) (+ (imagpart kid-size) (imagpart size))) *offset* (+ *offset* kid-size wrap-correction))))))))) (defmethod render-element ((e ul)) (let ((*offset* (+ *offset* #c(20 15))) (*line-begin* (+ *line-begin* 20))) (+ #c(20 30) (call-next-method)))) (defmethod render-element ((e li)) (let ((*offset* (+ *offset* 30)) (*line-begin* (+ *line-begin* 30))) (let ((size (call-next-method))) (xlib:draw-rectangle *win* *fg-color-gcontext* (floor (- (realpart *offset*) 20)) (floor (+ (imagpart *offset*) 10)) 10 10 :fill-p) (+ (complex (realpart size) (+ 20 (imagpart size))) 30)))) (defmethod render-element ((e li*)) (let ((*offset* (+ *offset* 30)) (*line-begin* (+ *line-begin* 30))) (let ((size (call-next-method))) (+ (complex (realpart size) (+ 20 (imagpart size))) 30)))) (defmethod render-element ((e p)) (multiple-value-bind (w a d l r asc desc) (xlib:text-extents *font* "J") ;; <- Why exactly "J", Dan? :) (declare (ignore w a d l r)) (let ((n (call-next-method))) (complex (realpart n) (+ asc desc (imagpart n)))))) (defmethod render-element ((e br)) ;; (+ #c(0 30))) (multiple-value-bind (w a d l r asc desc) (xlib:text-extents *font* "J") ;; <- Why exactly "J", Dan? :) (declare (ignore w a d l r)) (complex 0 (+ asc desc)))) (defmethod render-element ((e image)) "syntax: (image filename &key x y width height x-align y-align (ignore-text nil)) Normally :x and :y, respectively, should _not_ be used. :x-align can be \"left\", \"center\", or \"right\". :y-align can be \"top\", \"center\", or \"bottom\". :ignore-text means that *offset* will be returned unchanged." (destructuring-bind (filename &key x y width height x-align y-align (ignore-text nil)) (element-content e) (let* ((pathname (merge-pathnames filename *slides-pathname*)) (clx-image (or (slot-value e 'clx-image) (ppm:load-ppm-into-clx-image_depth pathname *default-display-depth*))) (image-gcontext (xlib:create-gcontext :drawable *win*)) (width (or width (xlib:image-width clx-image))) (height (or height (xlib:image-height clx-image))) (x-pos (cond ((equal x-align "center") (/ (- (xlib:drawable-width *win*) width) 2)) ((equal x-align "right") (- (xlib:drawable-width *win*) *main-x-border* width)) ((equal x-align "left") *main-x-border*) (t (realpart *offset*)))) (y-pos (cond ((equal y-align "center") (/ (- (xlib:drawable-height *win*) height) 2)) ((equal y-align "bottom") (- (xlib:drawable-height *win*) *main-y-border* height)) ((equal y-align "top") *main-y-border*) (t (imagpart *offset*))))) (xlib:put-image *win* image-gcontext clx-image :x (or x (round x-pos)) :y (or y (round y-pos)) :width width :height height) (if ignore-text #c(0 0) (+ (complex 0 (+ 20 height))))))) ;;;;;;;;;;;;;;;;;;;;;;; ;;; render-slide function (defun render-slide (slide &optional page-no) ;; (xlib:put-image *win* *bg-image-gcontext* *bg-image-pixmap* :x 0 :y 0) ;; the following is much faster: (xlib:draw-rectangle *win* (if *show-bg-image* *bg-image-gcontext* *bg-color-gcontext*) 0 0 (xlib:drawable-width *win*) (xlib:drawable-height *win*) :fill-p) (let ((*offset* (complex *main-x-border* *main-y-border*)) (*line-begin* *main-y-border*)) (render-element slide)) (when page-no (render-page-number page-no)) (xlib:display-force-output *display*)) (defun render-page-number (number) (let* ((string (princ-to-string number)) (*offset* (complex (- *screen-width* 85) (- *screen-height* 60)))) (render-element string))) ;;;;;;;;;;;;;;;;;;;;;;; ;;; make-element methods (defgeneric make-element (parent class &rest content)) (defmethod make-element (parent (class string) &rest content) (declare (ignore parent content)) class) (defmethod make-element (parent (class (eql 'image)) &rest content) (let* ((filename (car content)) (pathname (merge-pathnames filename *slides-pathname*)) (clx-image (progn (format *trace-output* "~:[Not l~;L~]oading inline image ~a.~%" *preload-images* filename) (force-output) (when *preload-images* (ppm:load-ppm-into-clx-image_depth pathname *default-display-depth*))))) (make-instance class :parent parent :content content :clx-image clx-image))) (defmethod make-element (parent (class (eql 'configure)) &rest content) "syntax: (configure &key bg-image bg-color fonts) - :bg-image should be a filename of a ppm/pnm-image (relatively to the slides-pathname's directory). :bg-color expects a color name. If both are specified the image will be prefered. - fonts is a list of font specifications acc. to the syntax: (element &key fontname color shift-value). There is a special element *default-fontname* to define *default-fontname* and *default-fg-color*." (declare (ignore parent)) (destructuring-bind (&key bg-image bg-color fonts) content (when fonts (dolist (font fonts) (destructuring-bind (element &key fontname color shift-value) font (if (eql element '*default-fontname*) (progn (format *trace-output* "Changing defaults: ~@[*default-fontname* to ~a~]~@[ and ~]~@[*default-fg-color* to ~a~].~%" fontname (and fontname color) color) (when fontname (setf *default-fontname* fontname) (when (boundp '*display*) ;; only if *display* is bound, otherwise it will be set in #'start anyhow (setf *font* (get-font *default-fontname*)))) (when color (setf *default-fg-color* color))) (progn (format *trace-output* "Changing element ~a: ~@[fontname ~a~]~@[, color ~a~]~@[, shift-value ~a~].~%" element fontname color shift-value) (when fontname (setf (element-fontname (find-class element)) fontname)) (when color (setf (element-color (find-class element)) color)) (when shift-value (setf (element-shift-value (find-class element)) shift-value))))))) (when bg-color (setf *default-bg-color* bg-color) (setf *show-bg-image* nil)) (when bg-image (format *trace-output* "Loading background image ~a.~%" bg-image) (force-output) (when (or (not *debug-do-not-load-bg-image*) (and *debug-do-not-load-bg-image* (not (boundp '*bg-clx-image*)))) ; (unless *debug-do-not-load-bg-image* (load-bg-image bg-image)) (setf *show-bg-image* t))) nil) (defmethod make-element (parent (class t) &rest content) (let ((instance (make-instance class :parent parent))) (setf (element-content instance) (mapcar (lambda (c) (apply #'make-element instance (if (listp c) c (list c)))) content)) instance)) ;;;;;;;;;;;;;;;;;;;;;;; ;;; restore defaults (defmacro restore-element-classes-defaults () `(progn (format *trace-output* "Restore default values for all elements.~%") ,@(mapcar (lambda (class-name) `(progn ,@(mapcar (lambda (slot-name) (let ((accessor (create-name 'element slot-name))) `(setf (,accessor (find-class ',class-name)) (,(create-name accessor 'default) (find-class ',class-name))))) '(fontname color shift-value)))) *element-classes*))) (defun restore-defaults () (restore-element-classes-defaults) (setf *default-fontname* *default-fontname-default*) (setf *default-bg-color* *default-bg-color-default*) (setf *default-fg-color* *default-fg-color-default*) (setf *show-bg-image* nil) (setf *last-foil* 0) t) ;;;;;;;;;;;;;;;;;;;;;;; ;;; load-slides function (defun load-slides (&optional (pathname *slides-pathname* new-pathname) &key (preload-images *preload-images* new-pi)) "Yes, I do know that using both &optinal and &key can be confusing. Think of (load-slides) without any parameter as syntactic sugar while you are creating a slide set. :) Be aware that :preload-images toggles the preloading of images *globally* and not only for this invokation of load-slides!" (restore-defaults) (when new-pathname (setf *slides-pathname* pathname)) (when new-pi (setf *preload-images* preload-images)) (if (and *slides-pathname* (probe-file *slides-pathname*)) (progn (format *trace-output* "Loading slides definition in file ~a.~%" *slides-pathname*) (setf *slides* (remove nil (with-open-file (slides-file pathname :direction :input) (let ((*package* #.*package*)) (loop for form = (read slides-file nil nil) while form collect (apply #'make-element nil form))))))) (format *trace-output* "Could not load slides definition as the file ~a is not existing.~%Please load one using (load-slide pathname) before starting the slide show with (start) or (go-on)." *slides-pathname*))) (load-slides) ;; <---- !!! ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; go-on, start, and run-core (defmacro special-let* (variables &rest body) `(let* ,variables (declare (special ,@(mapcar (lambda (var) (if (symbolp var) var (car var))) variables))) ,@body)) (defun go-on (&optional foil) "Start the slide show at foil *last-foil*, or given by the optional parameter :foil. control keys: ------------ Space or mouse button: next slide Backspace: previous slide q: quit slide show r: reload slide definition file and repaint slide" (start :foil (or foil *last-foil*))) (defun start (&key (foil 0) width height (host *host*)) "Start the slide show. control keys: ------------ Space or mouse button: next slide Backspace: previous slide q: quit slide show r: reload slide definition file and repaint slide" (unless *slides* (load-slides *slides-pathname*)) (special-let* ((*display* (xlib:open-display host)) (*screen* (xlib:display-default-screen *display*)) (*default-display-depth* (xlib:screen-root-depth *screen*)) (*colormap* (ppm:initialize ;; <- ugly side effect! (xlib:screen-default-colormap *screen*))) (*screen-width* (or width (xlib:screen-width *screen*))) (*screen-height* (or height (xlib:screen-height *screen*))) (*win* (xlib:create-window :parent (xlib:screen-root *screen*) :x 0 :y 0 :width *screen-width* :height *screen-height* :event-mask '(:exposure :button-press :key-release) ;; :background *bg-image-pixmap* ;; :background (colorname-to-color "midnightblue"))) )) (*font* (get-font *default-fontname*)) (*foreground-pixel* (xlib:screen-black-pixel *screen*)); default-foreground-pixel (*background-pixel* (xlib:screen-white-pixel *screen*)); default-background-pixel (*fg-color-gcontext* (xlib:create-gcontext :cache-p nil :drawable *win* :fill-style :solid :background *background-pixel* :foreground (colorname-to-color *default-fg-color*) :font *font*)) (*bg-color-gcontext* (xlib:create-gcontext :drawable *win* :fill-style :solid :background *background-pixel* :foreground (colorname-to-color *default-bg-color*) :font "fixed")) (*bg-image-pixmap* (when *show-bg-image* (xlib:image-pixmap (xlib:screen-root *screen*) *bg-clx-image*))) (*bg-image-gcontext* (xlib:create-gcontext :drawable *win* :tile *bg-image-pixmap* :fill-style :tiled))) (unwind-protect (progn (xlib:set-wm-properties *win* :name 'Exhibition :icon-name "Exhibition" :resource-name "Exhibition" :resource-class 'Exhibition ;; :command (list* 'hello-world host args) ;; :x x :y y :width width :height height ;; :min-width width :min-height height ;; :input :off :initial-state :normal ) (run-core foil)) ;; close screen (xlib:close-display *display*)))) (defun run-core (&optional (number 0)) (xlib:map-window *win*) (labels ((repaint () (if (< number (length *slides*)) (progn (render-slide (elt *slides* number) (when (not (zerop number)) number)) nil) t))) ;; (load-slides) ;; (if (>= number (length *slides*)) ;; (setf number (1- (length *slides*))) ;; (if (< number 0) ;; (setf number 0))) ;; (repaint) superfluous (xlib:event-case (*display* :discard-p t :force-output-p t) (exposure (window count) (when (zerop count) ;; Ignore all but the last exposure event (xlib:with-state (window) (repaint)));(render-slide (elt *slides* number) ; (when (not (zerop number)) ; number)))) nil) ; (button-press () ; (when (< number (1- (length *slides*))) ; (incf number)) ; (repaint)) (key-release (code state) (multiple-value-prog1 (case (xlib:keycode->character *display* code state) (#\Space (when (< number (1- (length *slides*))) (incf number)) (repaint)) (#\Backspace (when (> number 0) (decf number)) (repaint)) (#\r (load-slides) (repaint)) (#\q t) (t nil)) (setf *last-foil* number))))) *last-foil*)