(defpackage htmlcal
  (:export make-schedule make-page)
  (:use common-lisp))

(in-package htmlcal)

;; Create a schedule in tabular form
;; Returns multiple values:  The table itself; default stylesheet
;; Row height is calculated based on minor-resolution and hour-height,
;; so if you override the default stylesheet, be aware that your
;; requested height may not be granted!
(defun make-schedule (sched &key 
			    (dialect 'xhtml)
			    (start-time '8.0)
			    (end-time '19.0)
			    (minor-resolution '0.5) ;hrs per row of granularity
			    (major-resolution '2)   ;minor rows per major row
			    (hour-pixels '80)       ;an hour should be _ pixels tall
			    (time-mode '24hr)
			    )

  (let ((incr-small minor-resolution)
	(incr-big major-resolution)
	(hour-height (list hour-pixels "px"))
	(days (list '"sun" '"mon" '"tue" '"wed" '"thu" '"fri" '"sat"))
	)

    ;;DEBUG
;    (format t "Days: ~S~% Sched: ~S~%" days sched)
    (let ((claimed-times '()))      
      
      
    (defun render-time (time)
      (let ((render-hour 
	     (lambda (h)
	       (cond ((equal time-mode '24hr) (format 'nil "~2,'0D" h))
		     ((equal time-mode '12hr) (format 'nil "~2,'0D"
						      (if (< h 13)
							  h
							(- h 12))))
		     ('true (format 'nil "~D" h)))))
	    (render-min 
	     (lambda (m)
	       (format 'nil "~2,'0D"
		       (floor (* 60 m)))))
	    (render-suffix 
	     (lambda (time)
	       (cond ((equal time-mode '24hr) "")
		     ((equal time-mode '12hr) 
		      (if (>= time 12.0)
			  "PM"
			"AM"))
		     ('true 'nil)))))
	
	(multiple-value-bind (hour min) (truncate time)
			     (format 'nil "~A:~A ~A"
				     (funcall render-hour hour)
				     (funcall render-min min)
				     (funcall render-suffix time)))))
	
	       
    
    ;; How do we display a scheduled item?
    (defun render-event (e context)

      (defun linkify (text url)
	(if (equal url '())
	    text
	  (format 'nil "<a href=\"~A\">~A</a>"
		  url
		  text)))
      
      ;; Course Handling
      (defun coursep (e)
	(if (listp e)
	    (equal (first e) "course")
	  'nil))
      (defun render-course (c context)
	(let ((cname (first c))
	      (ctime (second c))
	      (url (third c))
	      )
	  ;(format t "~A" url)
	  (format 'nil "<div class =\"courseblock\" ><span class=\"coursename\">~A</span><br />~A<br />~A - ~A</div>" 
		  (linkify cname url) ctime (render-time (first context)) (render-time (second context)))))
      

      ;; Meeting Handling
      (defun meetp (e)
	(if (listp e)
	    (equal (first e) "meeting")
	  'nil))
      (defun render-meet (c context)
	(let ((cname (first c))
	      (ctime (second c))
	      (url (third c))
	      )
	  (format 'nil "<div class =\"meetingblock\" >Meet <span class=\"meetingperson\">~A</span><br />~A<br />~A - ~A</div>" (linkify cname url) ctime (render-time (first context)) (render-time (second context)))))
      
      (cond 
       ((coursep e) (render-course (second e) context))
       ((meetp e) (render-meet (second e) context))
       ('true (format 'nil "~S" e))
       ))
  
    
    ;; Make rows
    (defun make-rows (sched)
      
      (defun make-time-cell (time)
	(if (equal '0.0 (mod time (* incr-small incr-big)))
	    (format 'nil "<td rowspan = ~C~A~C> ~D </td>" 
		    #\" 
		    incr-big
		    #\" 
		    (render-time time))
	  'nil))
      
      
      (defun make-tall-cell (type height contents)
	(let ((tag (cond ((equal type 'header) "th")
			 ('true "td"))))
	  (concatenate 'string
		       "<"
		       tag
		       (if (> height 1)
			   (format 'nil " rowspan=\"~D\"  " height)
			 'nil)
		       ">"
		       contents
		       "</"
		       tag
		       ">"
		       )))
      
      (defun make-cell (type contents)
	(make-tall-cell type '1 contents))
	      
      
      (defun make-row (time)
;	(format t "make-row ~S ~%" time)
	(defun make-row-cells (time daylist)

	  ;; Define functions for handling marked times!
	  (defun clear-claims ()
	    (setq claimed-times '()))
    
	  (defun claim-time (day start stop)
	    (setq claimed-times 
		  (cons (list day start stop)
			claimed-times)))
    
	  (defun show-times ()
	    claimed-times)

	  (defun time-free-p (day start stop)
	    (defun real-free-p (day start stop list)
	      (cond ((equal list '()) 't)
		    ((and (equal (first (car list)) day)
			  (< (second (car list)) stop)
			  (> (third (car list)) start))
;		     (format t "Supressing ~A:~A - ~A ~%" day start stop)
		     'nil)
		    ('t (real-free-p day start stop (cdr list)))))
	    (real-free-p day start stop claimed-times))
	  
	  (defun get-scheduled-item (day start stop list)
	    (if (equal list '())
		'nil
	      (let* ((record (car list))
		     (other (cdr list))
		     (event-day (first record))
		     (event-start (second record))
		     (event-end (third record))
		     (event-info (fourth record)))
		
					;		(format t "current D/Sta/Sto: ~S/~S/~S ~% record D/Sta/Sto: ~S/~S/~S~%~%"
					;			day start stop event-day event-start event-end)
		    
		(if (and (equal day event-day)
			 (> event-end start)
			 (< event-start stop))
		    record
		  (get-scheduled-item day start stop other)))))
	  
	  (defun event-desc (record)
	    (fourth record))
	  
	  (defun event-start (record)
	    (let ((event-day (first record))
		  (event-start (second record))
		  (event-end (third record))
		  (event-info (fourth record)))
	      event-start))
	  
	   
	  (defun event-end (record)
	    (let ((event-day (first record))
		  (event-start (second record))
		  (event-end (third record))
		  (event-info (fourth record)))
	      event-end))
	  
	  (defun event-length (record)
	    (- (event-end record) (event-start record)))

;	  (defun event-rows (record this-row-time)
;	    (let* ((time-after-row (-(event-end record) this-row-time)))
;	      (/ (event-length record) incr-small)))

	  (defun event-rows (record this-row-time)
	    (let* ((time-after-row (-(event-end record) (incr-time this-row-time)))
		   (addl-rows-needed (ceiling (/ time-after-row incr-small))))
;	      (format t "Now ~D.  Ends ~D. Need ~D addl rows. ~%"
;		      this-row-time
;		      (event-end record)
;		      addl-rows-needed)
	      (if (< addl-rows-needed 1)
		  1
		(+ 1 addl-rows-needed))))
		   
	      
	      
	  
	  ;; Beginning of make-row-cells body
;	  (format t "make-row-cells ~S ~S ~%" (car daylist) time)
	  (if (equal daylist '()) 
	      'nil
	    (concatenate 'string
			 (let ((item (get-scheduled-item
				      (car daylist) time
				      (incr-time time)
				      sched)))
			   (cond ((equal item '()) (make-cell 'normal 'nil))
				 ((time-free-p (car daylist)
					       (event-start item)
					       (event-end item))
				  (claim-time (car daylist)
					      (event-start item)
					      (event-end item))

				  (make-tall-cell 'normal
						 ; 1
						  (event-rows item time)
						  (render-event
						   (event-desc item)
						   (list (event-start item)
							 (event-end item))
						   )))
				 ('t 'nil)))
			 (make-row-cells time (cdr daylist)))))
	  
	(concatenate 'string
		     "<tr class=\"schedrow\">"
		     (make-time-cell time)
		     (make-row-cells time days)
		     "</tr>"
		     (make-string 1 :initial-element #\Newline)))

      
      (defun make-header-row ()
	(defun make-day (days-left)
	  (defun render-day (daysymbol)
	    (format 'nil "~A" daysymbol))
	  (cond ((equal days-left '()) 'nil)
		('true 
		 (concatenate 'string
			      (make-cell 'header 
					 (render-day (car days-left)))
			      (make-day (cdr days-left))))))

	(concatenate 'string
		     "<tr>"
		     (make-cell 'header 'nil)
		     (make-day days)
		     "</tr>"
		     (make-string 1 :initial-element #\Newline)))
		     
		     

      
      (defun make-t-rows (time)
;	(format t "m-t-r ~S~%" time)
	(defun incr-time (time)
	  (+ time incr-small))
	(cond ((>= time end-time) 'nil)
	      ('true
	       (concatenate 'string
			    (make-row time)
			    
			    (make-t-rows (incr-time time))))))
      
      
      (concatenate 'string
		   (make-header-row)
		   (make-t-rows start-time)))
    
 
    
    (defun makestyle ()
      (concatenate 
       'string
       "<style type=\"text/css\">"
       (format 'nil 
	       "TR.schedrow { height: ~D~A; } ~% "
	       (ceiling (/ (first hour-height) (/ incr-big incr-small)))
	       (second hour-height) ;unit
	       )
       "TABLE   {table-layout: fixed; empty-cells: hide; border: outset 1px; }"
       "TD      {border: inset 1px; overflow: hidden;}"
       "TH      {border-bottom: inset 1px;}"
       ".courseblock {color: black; background-color: silver; height:100%; top:0; bottom:0; }"
       ".coursename {text-decoration: underline;}"
       ".meetingblock {color: black; background-color: pink; height:100%; top:0; bottom:0; }"
       ".meetingperson {text-decoration: underline;}"

       "</style>"))
    
    ;; Begin makeschedule body
    (values (format 'nil "<table>~A</table>~%"
		     (make-rows sched))
	     (makestyle)))))


(defun make-page (long-sched &key 
			     (dialect 'xhtml)
			     beforestyles
			     afterstyles
			     )
  (let ((dtd (cond ((equal dialect 'xhtml) 
		    "<?xml version=\"1.0\" encoding=\"UTF-8\"?>
<!DOCTYPE html 
     PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\"
    \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">
<html xmlns=\"http://www.w3.org/1999/xhtml\" xml:lang=\"en\" lang=\"en\">")
		   ('true
		    (error (format 'nil 
				   "Unsupported Dialect ~A." 
				   dialect)))))
	(schedulee (first long-sched))
	(timeframe (second long-sched))
	(footnote "<p>Generated using <a href=\"http://ericanderson.org/\">Eric Anderson</a>'s <a href=\"http://ericanderson.org/fun/projects.html\">gsched2</a>.</p>")
	(sched (third long-sched)))
    (multiple-value-bind 
     (body style) 
     (make-schedule sched :dialect dialect :end-time '21.0)
     (defun addsheets (slist)
       (if (equal slist 'nil)
	   ""
	 (format 'nil 
		 "<link rel=\"stylesheet\" href=\"~A\" type=\"text/css\" />~%~A"
		 (car slist)
		 (addsheets (cdr slist)))))
    
	
    
     (concatenate
      'string
      dtd
      "<head><title>"
      (format 'nil "~A's Schedule" schedulee)
      "</title>"
      (addsheets beforestyles)
      style
      (addsheets afterstyles)
      "</head><body>"
      (format 'nil "<h1>~A<br/>~A</h1>~%" schedulee timeframe)
      body
      footnote
      "</body></html>"))))