;;; --------------------------------------------------------------------
;;;     Title: Acclaim - A Simple Presentation Program
;;;   Authors: Daniel Barlow, Max-Gerd Retzlaff
;;;   Version: 0.20
;;;    Date of this version: May, 20th 2004, 20:51:23 CEST
;;;
;;;   First version by Daniel Barlow <dan@telent.net>
;;;   (see http://www.linux.org.uk/~dan/linux2003/viewer.lisp)
;;;   Changes by Max-Gerd Retzlaff <m.retzlaff@gmx.net>
;;;
;;;   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.
;;; --------------------------------------------------------------------

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; package definition

(defpackage #:acclaim
  (:use #:cl)
;;  (:require #:xlib #:ppm) ;; only pseudo code.. :(
  (:export #:start #:go-on #:load-slides))

(in-package :acclaim)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; class definitions

(defclass element ()
  ((content :initarg :content :accessor element-content)
   (parent :initarg :parent :accessor element-parent)))

(defclass horizontal-element (element) ())
(defclass i (horizontal-element) ())
(defclass tt (horizontal-element) ())
(defclass b (horizontal-element) ())
(defclass center (horizontal-element) ())

(defclass vertical-element (element) ())
(defclass slide (vertical-element) ())
(defclass title (vertical-element) ())
(defclass ul (vertical-element) ())
(defclass pre (vertical-element) ())
(defclass smallpre (vertical-element) ())
(defclass line (vertical-element) ())
(defclass p (vertical-element) ())
(defclass li (vertical-element) ())
(defclass li* (vertical-element) ())
(defclass br (vertical-element) ())
(defclass image (vertical-element)
  ((clx-image :initarg :clx-image)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; slide setting variables
;;
;; These variables should be set by a function like init-acclaim-slides..

;; 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/viewer/slides/lisp-ist-toll.slides")
;;  #p"/home/mgr/daten/coding/lisp/viewer/slides/ukuug-slides.lisp")
;;  #p"coding:viewer;slides;lisp-ist-toll.slides")
;;  #p"coding:viewer;slides;ukuug-slides.lisp")

(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)")

;;;;;;;;;;;;;;;;;;;;;;;
;; far too many variables..
;; Normally you do not have to change them.

(defvar *default-display-depth* ;; has to be before (defvar *bg-clx-image* ..)
  (ppm:initialize-host-default-display))

(defvar *show-bg-image* nil)
(defvar *default-fontname* "-*-helvetica-medium-r-*-*-*-240-*-*-*-*-*-*")
(defvar *default-bg-color* "midnightblue")
(defvar *default-fg-color* "yellow")
(defvar *bg-clx-image*)
(defvar *bg-image-pixmap*)
(defvar *bg-image-gcontext*)

(defvar *offset* (complex 0 0))
(defvar *main-x-border* 50)
(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)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; methods and functions

;;;;;;;;;;;;;;;;;;;;;;;
;;; miscellaneous functions

(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))

(defmacro make-render-element=around (element fontname &key fg-pixel shift-value)
  `(defmethod render-element :around ((element ,element))
     (let ((*font* (get-font ,fontname)))
       (xlib:with-gcontext
	,(if fg-pixel
	    `(*fg-color-gcontext* :font *font*
				  :foreground ,fg-pixel)
	   `(*fg-color-gcontext* :font *font*))
	,(if shift-value
	     `(+ (call-next-method) ,shift-value)
	   `(call-next-method))))))

(make-render-element=around title
  "-*-helvetica-medium-r-*-*-*-480-*-*-*-*-*-*"
   :fg-pixel *background-pixel*
   :shift-value #c(0 50))
(make-render-element=around pre
   "-*-courier-medium-r-*-*-*-240-*-*-*-*-*-*"			    
   :fg-pixel *background-pixel*)
(make-render-element=around smallpre
   "-*-courier-medium-r-*-*-*-180-*-*-*-*-*-*"
   :fg-pixel *background-pixel*)
(make-render-element=around tt
   "-*-courier-medium-r-*-*-*-240-*-*-*-*-*-*")
(make-render-element=around b
   "-*-helvetica-bold-r-*-*-*-240-*-*-*-*-*-*")
(make-render-element=around i
   "-*-helvetica-medium-o-*-*-*-240-*-*-*-*-*-*")

(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
	(width 0)
	(height 0))
    (loop
     (setf start (if i (1+ i) 0)
	   i (position #\Newline e :start (if i (1+ i) 0)))
     (multiple-value-bind (w 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))
       (xlib:draw-glyphs *win* *fg-color-gcontext*
			 (floor (realpart *offset*))
			 (floor (+ height ascent (imagpart *offset*)))
			 e
			 :start (or start 0)
			 :end (or i (length e)))
       (setf width (max width w)
	     height (+ ascent descent height))
       (unless i (return))))
    (complex width height)))

(defmethod render-element ((e element))
  (let ((size 0)
	(*offset* *offset*)
	(kids (element-content e)))
;;    (pprint kids *trace-output*)
    (loop
     (let ((kid (car kids)))
       (setf kids (cdr kids))
       (unless kid (return size))
       (let ((kid-size (render-element kid)))
	 (if (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))))
	     (setf size (complex (+ (realpart size) (realpart kid-size))
				 (max (imagpart kid-size) (imagpart size)))
		   *offset* (+ *offset* (realpart kid-size)))))))))

(defmethod render-element ((e br))
    (+ #c(20 30)))

(defmethod render-element ((e ul))
  (let ((*offset* (+ *offset* #c(20 15))))
    (+ #c(20 30) (call-next-method))))

(defmethod render-element ((e li))
  (let ((*offset* (+ *offset* 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)))
    (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")
    (declare (ignore w a d l r))
    (let ((n (call-next-method)))
      (complex (realpart n) (+ asc desc (imagpart n))))))

(defmethod render-element ((e image))
  "syntax: (image filename &key x y width height align (ignore-text nil))
Normally :x and :y, respectively, should _not_ be used.
:align can be \"left\", \"center\", or \"right\", being \"left\" the default.
:ignore-text means that *offset* will be returned unchanged."
  (destructuring-bind
      (filename &key x y width height 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 align "center")
		  (/ (- (xlib:drawable-width *win*) width) 2))
		 ((equal align "right")
		  (- (xlib:drawable-width *win*)
		     *main-x-border*
		     width))
		 (t (realpart *offset*)))))

    (xlib:put-image *win* image-gcontext clx-image
		    :x (or x x-pos)
		    :y (or y (imagpart *offset*))
		    :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: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)
;;  (xlib:put-image *win* *bg-image-gcontext* *bg-image-pixmap* :x 0 :y 0)
  (let ((*offset* (complex *main-x-border* 20)))
    (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 fontname &key 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 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)
      (load-bg-image bg-image)
      (setf *show-bg-image* t))
    (when fonts
      (dolist (font fonts)
	(destructuring-bind
	    (element fontname &key color shift-value)
	    font
	  (if (eql element '*default-fontname*)
	      (progn
		(format *trace-output* "Setting *default-fontname* to ~a~@[ and *default-fg-color* to ~a~].~%"
			fontname color)
		(setf *default-fontname* fontname)
		(when color
		  (setf *default-fg-color* color)))
	    (if (eql element 'title)
		(progn
		  (format *trace-output* "Setting font of element ~a, fontname ~a~@[, color ~a~]~@[, shift-value ~a~].~%"
			  element fontname color shift-value)
;; 		  (make-render-element=around
;; 		   element fontname
;; 		   :fg-pixel (colorname-to-color color)
;; 		   :shift-value shift-value))
;;  		  warning: crude hack follows.. :(
		  (let ((color (or color *default-fg-color*))
			(shift-value (or shift-value #c(0 50))))
		    (make-render-element=around
		     title fontname
		     :fg-pixel (colorname-to-color color)
		     :shift-value shift-value)))
	      (format *trace-output* "Sorry, make-render-element=around is a macro right now, and.. aehm.. Well, for now you can only define *default-fontname* and the element title.~%")))))))
  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))


;;;;;;;;;;;;;;;;;;;;;;;
;;; 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!"
  (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"
  (start :foil (or foil *last-foil*)))

(defun start (&key (foil 0)
		 width height
		 (host ""))
;  "start the slide show"
      (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*)