;;; -------------------------------------------------------------------- ;;; Title: Acclaim - A Simple Presentation Program ;;; Authors: Daniel Barlow, Max-Gerd Retzlaff ;;; Version: 0.24 ;;; Date of this version: Jun, 17th 2004, 14:50:19 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. ;;; ;;; There is a homepage for this program at: ;;; http://www.bl0rg.net/~mgr/acclaim.html ;;; or http://team.vantronix.net/~mgr/acclaim.html ;;; ;;; 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. ;;; - Inline images can be positioned by :x-align and :y-align. ;;; 0.23 - 0.24: - (Not really new, exiting features; mainly refacturing.) ;;; - Pseudo package my-pcl for importing of mop functions ;;; - Global variables for the default color, fontname, bg-color, ;;; and bg-clx-image removed and replaced by _class_ slots of ;;; the element slide. ;;; - fontname, color, shift-value, and bg-color (the latter ;;; only for a slide) are now instance specific; ;;; Hence you can write ((tt :color "white") "foo") to get a ;;; white tt, or ((slide :bg-color "blue" :color "green") ..) ;;; to get a blue slide with a default textcolor of green. ;;; - New elements slideset, font and page-number. ;;; - The page-numbers are now added to the slides themselves ;;; when the slides file is loaded (in load-slides) and not ;;; when the slide is displayed (in render-slide). ;;; - The slides of a slideset are now grouped as the content ;;; of a slideset element, as in: ;;; (slideset (configure ..) (slide ..) (slide ..)) ;;; It would be possible to define several slidesets in one ;;; file but right now only the first one is actually used. ;;; - New method element-property (and aliases element-fontname, ;;; element-color, etc.). It tries to get the property's value ;;; for the instance, if that's not set then for the class of ;;; the instance, then for the superclasses up to the element ;;; class itself. So if the class pre has the color "white", ;;; the subclass smallpre will also be white. ;;; - Due to the above changes the make-element configure method ;;; got much simpler. The format of a configure block is also ;;; easier: No keywords just a list of element setting blocks. ;;; - wm-properties also set to Acclaim and not to Exhibition now. ;;; - Hotkey #\s (for screenshot) added; the shots will be ;;; placed in the directory of the slides definition file. The ;;; pathname "/usr/bin/scrot" for the screen capture program ;;; "scrot" is hardcoded. Go to http://linuxbrit.co.uk/scrot/ ;;; to get scrot (or do "apt-get install scrot" on Debian). ;;; ;;; -------------------------------------------------------------------- ;;; -*- Mode: Lisp; -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; package definition (defpackage #:my-pcl (:use #+sbcl #:SB-PCL #+openmcl #:CCL #+cmu #:PCL #+sbcl #:sb-ext) (:export #:class-direct-superclasses #:validate-superclass #:run-program)) ;; #:standard-class)) (defpackage #:acclaim (:use #:cl #:my-pcl) ;;(:require #:xlib #:ppm) ;; only pseudo code.. use asdf (: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 bg-color bg-clx-image) (defmethod validate-superclass ((class element-class) (super standard-class)) t) (defvar *element-classes* nil) (defmacro def-element-class (class-name (&key fontname color shift-value bg-color) &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) (bg-color ,bg-color))))) (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 slideset () (element) ((configuration :initarg :configuration :accessor slideset-configuration :initform nil))) (def-element-class element () () ((content :initarg :content :accessor element-content :initform nil) (parent :initarg :parent :accessor element-parent :initform nil) ;; (root :initarg :root :accessor element-root :initform nil) (fontname :initarg :fontname :accessor element-fontname :initform nil) (color :initarg :color :accessor element-color :initform nil) (shift-value :initarg :shift-value :accessor element-shift-value :initform nil))) (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 () (horizontal-element) ()) (def-element-class font () (horizontal-element) ()) (def-element-class vertical-element () (element) ()) (def-element-class slide (:fontname "-*-helvetica-medium-r-*-*-*-240-*-*-*-*-*-*" :color "yellow" :shift-value #c(0 0) :bg-color "midnightblue") (vertical-element) ((bg-color :initarg :bg-color :accessor slide-bg-color :initform nil) (bg-clx-image :initarg :bg-image :accessor slide-bg-clx-image :initform nil) ;; (bg-image-pixmap :initarg :bg-image-pixmap :accessor slide-bg-image-pixmap :initform nil) ;; (bg-image-gcontext :initarg :bg-image-gcontext :accessor slide-bg-image-gcontext :initform nil) )) (def-element-class title (:fontname "-*-helvetica-medium-r-*-*-*-480-*-*-*-*-*-*" :color "white" :shift-value #c(0 40)) (vertical-element) ()) (def-element-class ul () (vertical-element) ()) (def-element-class pre (:fontname "-*-courier-medium-r-*-*-*-240-*-*-*-*-*-*" :color "white") (vertical-element) ()) (def-element-class smallpre (:fontname "-*-courier-medium-r-*-*-*-180-*-*-*-*-*-*") (pre) ()) (def-element-class line () (vertical-element) ()) (def-element-class p () (vertical-element) ()) (def-element-class li () (vertical-element) ()) (def-element-class li* () (vertical-element) ()) (def-element-class br () (vertical-element) ()) (def-element-class image () (vertical-element) ((clx-image :initarg :clx-image))) (def-element-class page-number () (vertical-element) ()) ) ;; <----- !!!!!! ) of (eval-when.. !!!!! (defgeneric element-property (element property-name)) (defmethod element-property ((element element) property-name) (let* ((class (class-of element)) (property (or (slot-value element property-name) (slot-value class property-name)))) (if property property (if (eql class (find-class 'element)) nil ;; Yes, this is the right thing! ;; (progn ;; (assert property (property) ;; ;; This means that nil is not allowed as a value.. Is this always okay? ;; "Could not find a value for property ~a.~%" property-name) ;; property) (element-property (make-instance (car (class-direct-superclasses class))) property-name))))) (defgeneric element-fontname (element)) (defmethod element-fontname ((element element)) (element-property element 'fontname)) (defgeneric element-color (element)) (defmethod element-color ((element element)) (element-property element 'color)) (defgeneric element-shift-value (element)) (defmethod element-shift-value ((element element)) (element-property element 'shift-value)) (defgeneric element-bg-color (element)) (defmethod element-bg-color ((element element)) (element-property element 'bg-color)) (defgeneric element-bg-clx-image (element)) (defmethod element-bg-clx-image ((element element)) (element-property element 'bg-clx-image)) ;;;;;;;;;;;;;;;;;;;;;;; ;; 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 *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 *slidesets* nil) (DEFVAR *DISPLAY*) (DEFVAR *SCREEN*) (DEFVAR *SCREEN-width*) (DEFVAR *SCREEN-height*) (DEFVAR *COLORMAP*) (DEFVAR *WIN*) (DEFVAR *FONT*) (defvar *fg-color*) (DEFVAR *fg-color-gcontext*) (DEFVAR *bg-color-gcontext*) (DEFVAR *foreground-pixel*) (DEFVAR *background-pixel*) ;;;;;;;;;;;;;;;;;;;;;;; ;; debug variables (defvar *debug-boxes* nil) (eval-when (:compile-toplevel :load-toplevel :execute) (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-image (filename &optional (images-dir *slides-pathname*)) "Load a pnm file (given by filename) and return the resulting clx-image; filename is relative to images-dir (default *slides-pathname*)." (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))) (defun get-slides (slideset-number) (element-content (nth slideset-number *slidesets*))) ;;;;;;;;;;;;;;;;;;;;;;; ;;; render-element methods (defgeneric render-element (e)) (defmethod render-element :around ((element element)) (let* ((fontname (element-fontname element)) (color (element-color element)) (shift-value (or (element-shift-value element) #c(0 0))) (*font* (if fontname (get-font fontname) *font*)) (*fg-color* (if color (colorname-to-color color) *fg-color*))) (if (or fontname color) (xlib:with-gcontext (*fg-color-gcontext* :font *font* :foreground *fg-color*) (+ shift-value (call-next-method))) (+ 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 page-number)) (let ((*wrap-lines* nil) (*offset* (complex (- *screen-width* 85) (- *screen-height* 60)))) (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))) ;; (format *trace-output* "font: ~a, element-class: ~a~%" *font* (class-of element)) (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* ((clx-image (or (slot-value e 'clx-image) (load-image filename))) (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) ;; (xlib:put-image *win* *bg-image-gcontext* ;; (element-bg-clx-image (find-class 'slide)) ;; :x 0 :y 0) ;; the following is much faster: (xlib:with-gcontext (*bg-color-gcontext* :foreground (colorname-to-color (element-bg-color slide))) (xlib:draw-rectangle *win* (if (and *show-bg-image* (not (slide-bg-color slide))) *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)) (xlib:display-force-output *display*)) ;;;;;;;;;;;;;;;;;;;;;;; ;;; 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 (element-definition block)) with element-definition-block as: (element &key fontname color shift-value bg-color bg-image) - :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." (declare (ignore parent)) (dolist (element content) (destructuring-bind (element &key fontname color shift-value bg-color bg-image) element (format *trace-output* "Changing element ~a: ~@[fontname ~a~]~@[, color ~a~]~@[, shift-value ~a~]~@[, bg-color ~a~]~@[, bg-iamge ~a~].~%" element fontname color shift-value bg-color bg-image) (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 (element-bg-color (find-class element)) bg-color) (setf *show-bg-image* nil)) (when bg-image (if (or (not *debug-do-not-load-bg-image*) (and *debug-do-not-load-bg-image* (not (element-bg-clx-image (find-class element))))) (progn (format *trace-output* "Loading background image ~a.~%" bg-image) (setf (element-bg-clx-image (find-class element)) (load-image bg-image))) (format *trace-output* "Not loading background image ~a.~%" bg-image)) (setf *show-bg-image* t)))) nil) (defmethod make-element (parent (class t) &rest content) (let ((instance (if (consp class) (apply #'make-instance (car class) :parent parent (cdr class)) (make-instance class :parent parent)))) (setf (element-content instance) (remove nil (mapcar (lambda (c) (apply #'make-element instance (if (listp c) c (list c)))) content))) instance)) ;;;;;;;;;;;;;;;;;;;;;;; ;;; restore defaults (defmacro restore-defaults () ;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))))) (if *debug-do-not-load-bg-image* '(fontname color shift-value bg-color) '(fontname color shift-value bg-color bg-clx-image))))) *element-classes*) ;; (setf *show-bg-image* nil) ;; (setf *last-foil* 0) )) ;(defun restore-defaults () ; (restore-element-classes-defaults) ;;; (setf *show-bg-image* nil) ;;; (setf *last-foil* 0) ; t) ;;;;;;;;;;;;;;;;;;;;;;; ;;; add page numbers (defun add-page-number-to-slide (number slide) (let ((string (princ-to-string number))) (setf (element-content slide) (append (element-content slide) (list (make-instance 'page-number :content (list string))))))) (defun add-page-numbers-to-slideset (slideset) (do* ((i 2 (1+ i)) ;; do not number the front page, and start with 2 (slides (cdr (element-content slideset)) (cdr slides)) (slide (car slides) (car slides))) ((null slides) slideset) ; (format t "i: ~a, slide: ~a~%" i slide) (add-page-number-to-slide i slide))) ;;;;;;;;;;;;;;;;;;;;;;; ;;; load-slides function (defun load-slides (&optional (pathname *slides-pathname* new-pathname) &key (preload-images *preload-images* preload-images-p)) "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* (merge-pathnames pathname *slides-pathname*))) (when preload-images-p (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 *slidesets* (remove nil (with-open-file (slides-file *slides-pathname* :direction :input) (let ((*package* #.*package*)) (loop for form = (read slides-file nil nil) while form collect (apply #'make-element nil form)))))) ;; add page numbers to the slidesets (mapcar #'add-page-numbers-to-slideset *slidesets*)) (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: next slide Backspace: previous slide q: quit slide show r: reload slide definition file and repaint slide s: put a screen shot in the directory of the slides definition file" (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 *slidesets* (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"))) )) (*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*)) (*bg-color-gcontext* (xlib:create-gcontext :drawable *win* :fill-style :solid :background *background-pixel*)) (*bg-image-pixmap* (when *show-bg-image* (xlib:image-pixmap (xlib:screen-root *screen*) (element-bg-clx-image (find-class 'slide))))) (*bg-image-gcontext* (xlib:create-gcontext :drawable *win* :tile *bg-image-pixmap* :fill-style :tiled))) (unwind-protect (progn (xlib:set-wm-properties *win* :name '|Acclaim| :icon-name "Acclaim" :resource-name "Acclaim" :resource-class '|Acclaim| ;; :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 (get-slides 0))) (progn (render-slide (elt (get-slides 0) number)) nil) t))) ;; ;; assure that number is not out of range ;; (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))) nil) ;; (button-press () ;; (when (< number (1- (length (get-slides 0)))) ;; (incf number)) ;; (repaint)) (key-release (code state) (multiple-value-prog1 (case (xlib:keycode->character *display* code state) (#\Space (when (< number (1- (length (get-slides 0)))) (incf number)) (repaint)) (#\Backspace (when (> number 0) (decf number)) (repaint)) (#\r (load-slides) (repaint)) ;; bash hack for generating a pdf out of the screenshots: ;; for i in slide-*.pnm; do pnmtops $i ; done | ps2pdf - > all.pdf (#\s (run-program "/usr/bin/scrot" (list (format nil "~aslide-~3,'0d.pnm" (directory-namestring *slides-pathname*) (1+ number)))) nil) (#\q t) (t nil)) (setf *last-foil* number))))) *last-foil*)