exercises.lisp Unix DownloadWindows Download
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; File		     - exercises.lisp
;; Description	     - exercise manager
;; Author	     - Gail Anderson (ga at HELLESVEAN)
;; Created On	     - Wed May 16 13:59:22 2001
;; Last Modified On  - Mon Jul  9 01:38:17 2001
;; Last Modified By  - Tim Bradshaw (tfb at lostwithiel)
;; Update Count	     - 237
;; Status	     - Unknown
;; 
;; $Id: exercises.lisp,v 1.2 2003/01/23 09:04:20 colin Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Copyright 2001 Franz Inc

(in-package :cl-user)

;;; use htout

(eval-when (compile load eval)
  (use-package :htout))

;;; Parameters

;;; directory where input specification (in HTML) and solution (in
;;; Lisp) live.  This directory is merged with
;;; *DEFAULT-PATHNAME-DEFAULTS*

(defparameter *input-directory* '(:relative "data"))

;;; directory where output HTML files go. This directory is merged
;;; with *DEFAULT-PATHNAME-DEFAULTS*

(defparameter *output-directory* '(:relative "output"))

;;; all exercise specifications contain a "basename" slot which is
;;; a string; we look for input files beginning with that string, and
;;; generate output files beginning with it

(defparameter *html-extension* "html")
(defparameter *lisp-extension* "lisp")
(defparameter *out-spec-postfix* "-spec")
(defparameter *out-soln-postfix* "-soln")
    
  
;;; Now a hashtable where all exercises are stored, keyed by name.

(defparameter *all-exercises*
    (make-hash-table :test #'equal))
  

;;; OK that works.




;;; Now a class to represent exercise specifications


(defclass exercise ()
  ((name
    :initarg :name
    :accessor name
    :initform "")
   (basename
    :initarg :basename
    :accessor basename
    :initform "")
   (author
    :initarg :author
    :accessor author
    :initform "")
   (copyright
    :initarg :copyright
    :accessor copyright
    :initform "")
   (difficulty
    :initarg :difficulty
    :accessor difficulty
    :initform "")
   (input-spec
    :accessor input-spec)
   (input-soln
    :accessor input-soln)
   (output-spec
    :accessor output-spec)
   (output-soln
    :accessor output-soln)
   (specification
    :accessor specification)
   (solutions
    :accessor solutions)
   (solns-src
    :accessor solns-src
    :initform '()))
   (:documentation
    "Class definition for an exercise specification. Slots are:
         name: the name of the exercise; it's best if this is unique
         basename: a string which begins names of all input/output files 
                   for this exercise
         author: author of the exercise, if known
         copyright: copyright on the exercise, if any
         documentation: an indication of the difficulty of the exercise; 
                   usually eay, medium or hard 
         input-spec: the pathname of the input specification file; 
                   cached when an instance is created
         input-soln: the pathname of the input solution file; 
                   cached when an instance is created
         output-spec: the pathname of the output specification file; 
                   cached when an instance is created
         output-spec: the pathname of the output solution file; 
                   cached when an instance is created
         specification: a string containing the contents of the input
                   specification file; cached when an instance is created
         solution: a string containing the contents of the input 
                   solution file; cached when an instance is created
         solns-src: a list containing all forms read from the input
                   solution file; cached when an instance is created."))


;;; After method for initialize-instance, which caches filenames and
;;; Lisp specifications/solutions for later use

(defmethod initialize-instance :after ((ex exercise) &key)
  (flet ((check-string (slot &optional nonemptyp)
	   (if (not (typep (slot-value ex slot) 'string))
	       (error "Slot ~A of exercise: value must be a string." slot))
	   (if (and nonemptyp (string= (slot-value ex slot) ""))
	       (error "Slot ~A of exercise: value must not be the empty string." slot)))
	 (check-path (slot)
	   (if (not (probe-file (slot-value ex slot)))
	       (error "Slot ~A of exercise: file ~A does not exist." 
		      slot (pathname-name (slot-value ex slot))))))
	   
    ;; check values of all user-specified slots are strings, etc.
    (check-string 'name t)
    (check-string 'basename t)
    (check-string 'author)
    (check-string 'copyright)
    (check-string 'difficulty)
    (let ((basename (basename ex)))
      ;; using basename and parameters generate and cache input and
      ;; output pathnames, mnerging with whatever the current value of
      ;; *DEFAULT-PATHNAME-DEFAULTS* is.
      (setf (input-spec ex)
	(merge-pathnames
	 (make-pathname :directory *input-directory*
			:name basename
			:type *html-extension*)))
      (check-path 'input-spec)
      (setf (input-soln ex)
	(merge-pathnames
	 (make-pathname :directory *input-directory*
			:name basename
			:type *lisp-extension*)))
      (check-path 'input-soln)
      (setf (output-spec ex)
	(merge-pathnames
	 (make-pathname :directory *output-directory*
			:name (concatenate 'string basename *out-spec-postfix*)
			:type *html-extension*)))
      (setf (output-soln ex)
	(merge-pathnames 
	 (make-pathname :directory *output-directory*
			:name (concatenate 'string basename *out-soln-postfix*)
			:type *html-extension*)))
      ;; cache contents of input specification and solution files
      (setf (specification ex)
	(snarf-file (input-spec ex)))
      (setf (solutions ex)
	(snarf-file (input-soln ex)))
      ;; cache Lisp source forms from solution
      (with-input-from-string (solns (solutions ex))
	(with-standard-io-syntax
	  (let ((*read-eval* nil))
	    (setf (solns-src ex)
	      (loop for soln = (read solns nil solns)
		  until (eq soln solns)
			collect soln))))))))
	     
   
   
;;; snarf a file into a string

(defun snarf-file (file)
  ;; encoding-resistant file reader.  You can't use FILE-LENGTH
  ;; because in the presence of variable-length encodings (and DOS
  ;; linefeed conventions) the length of a file can bear little resemblance
  ;; to the length of the string it corresponds to.  Reading each line 
  ;; like this wastes a bunch of space but does solve the encoding
  ;; issues.
  (with-open-file (in file
                      :direction ':input)
    (loop for read = (read-line in nil nil)
          while read
          for i upfrom 1
          collect read into lines
          sum (length read) into len
          finally (return
                   (let ((huge (make-string (+ len i))))
                     (loop with pos = 0
                           for line in lines
                           for len = (length line)
                           do (setf (subseq huge pos) line
                                    (aref huge (+ pos len)) #\Newline
                                    pos (+ pos len 1))
			 finally (return huge)))))))


;;; Grab a file with LHTML in it and return a function which evaluates
;;; it.  This is not used since it is kind of dangerous (it doesn't
;;; check the file carefully at all so bad things could happen.  It
;;; should not be too hard to check the file adequately (ask tfb)).  I
;;; left this here because it's so Lispy...
;;;

(defgeneric snarf-lhtml-file (file/stream))

(defmethod snarf-lhtml-file ((filename string))
  (snarf-lhtml-file (parse-namestring filename)))

(defmethod snarf-lhtml-file ((filename pathname))
  (with-open-file (in filename :direction ':input)
    (snarf-lhtml-file in)))

(defmethod snarf-lhtml-file ((in stream))
  (with-standard-io-syntax
    (let ((*read-eval* nil))
      (let ((sn (make-symbol "S")))
	(values (compile nil
			 `(lambda (,sn)
			    (with-html-output (,sn)
			      ,@(loop for read = (read in nil in)
				    until (eq read in)
				    collect read)))))))))


;;; macro for defining an exercise

(defmacro defex (name &key
		      (basename "") (author "") 
		      (copyright "") (difficulty ""))
  (unless (stringp name)
    ;; NAME must be a *literal* string 
    (error "Name ~A is not a string" name))
  `(progn
     (setf (gethash ',name *all-exercises*)
       (make-instance 'exercise 
	 :name ',name
	 :basename ,basename
	 :author ,author
	 :copyright ,copyright
	 :difficulty ,difficulty))
     ',name))


		  

;;; a simple function for mapping over all exercises

(defun map-exercises (function)
  (maphash #'(lambda (k v)
	       (declare (ignore k))
	       (funcall function v))
	   *all-exercises*))


;;; a function for collecting exercises, and returning them as a list;
;;; collects all by default; or if test is specified only collects
;;; those for which test returns non-nil

(defun collect-exercises (&optional (test #'identity))
  (let ((collected '()))
    (map-exercises #'(lambda (ex)
		       (when (funcall test ex)
			 (push ex collected))))

    collected))


;;; Sort a list of exercises; FIELDS is a list of slot names and optionally
;;; comparators.  Each element is either:
;;;   slot-name - values compared with STRING< and STRING=.
;;;   (slot-name <-fn eq-fn) - values compared with <-fn for ordering 
;;;                            and eq-fn for equivalence.

(defun sort-exercises (exlist &optional fields)
  (labels ((exercise< (ex1 ex2 flds)
	     ;; FLDS is a defaulted version of FIELDS above.
	     (if (null flds)
		 t
		 (destructuring-bind (slotname <-fn eq-fn) (first flds)
		   (let ((ex1-slot (slot-value ex1 slotname))
			 (ex2-slot (slot-value ex2 slotname)))
		     (cond ((funcall eq-fn ex1-slot ex2-slot)
			    (exercise< ex1 ex2 (rest flds)))
			   ((funcall <-fn ex1-slot ex2-slot)
			    t)
			   (t nil)))))))
    (if (null fields)
	exlist
	(let ((defaulted-fields (mapcar #'(lambda (f)
					    (etypecase f
					      (symbol
					       (list f #'string< #'string=))
					      (cons f)))
					fields)))
	  (sort exlist #'(lambda (e1 e2)
			   (exercise< e1 e2 defaulted-fields)))))))


(defmacro select-exercises ((exname) &body boolean-expression)
  ;; EXNAME is bound to each exercise.  If BOOLEAN-EXPRESSION returns
  ;; non-NIL that exercise is selected.  If no BOOLEAN-EXPRESSION is
  ;; given return all exercises.
  (let ((the-expression (or boolean-expression '(t))))
    `(collect-exercises #'(lambda (,exname)
			    (declare (ignorable ,exname))
			    ,@the-expression))))



;;; a function which outputs details of an exercise as HTML to a stream

(defun output-exercise-as-html (exercise str outputsolnp)
  (with-html-output (str)
    (flet ((tablify (descr val &optional major-p)
	     (htm
	      ((:tr :valign "baseline")
	       ((:th :align "right")
		(fmt "~A -" descr))
	       ((:th :align "left")
		(if major-p
		    (htm
		     (:h2 (fmt "~A" val)))
		    (htm
		     (:h4 (fmt "~A" val)))))))))
      (htm
       (:table
	(:tbody
	 (tablify "Exercise name" (name exercise) t)
	 (tablify "Author" (author exercise))
	 (tablify "Copyright" (copyright exercise))
	 (tablify "Difficulty" (difficulty exercise))))
       (:h3 "Specification")
       (format str "~A" (specification exercise))
       (when outputsolnp
	 (htm
	  (:h3 "Solutions")
	  (:listing (format str "~A" (solutions exercise)))))))))



;;; a function which creates two standalone output files for the
;;; argument exercise
	
(defun output-exercise-standalone-html (exercise &key 
						 (specstream nil)
						 (solnstream nil))
  (let ((name (format nil "Exercise name: ~A" (name exercise)))
	(dlctitle (format nil "Dynamic Learning Center"))
	(spectitle (format nil "Short Exercise Specification"))
	(solntitle (format nil "Short Exercise Specification and Solution")))
    (flet ((output-file (str title solnp)
	       (with-html-output (str)
		 (:html
		  (:head
		   (:title (concatenate 'string title " " name)))
		  (:body
		   (:h1 dlctitle)
		   (:h2 title)
		   (output-exercise-as-html exercise str solnp))))))
      ;; write out the output specification file
      (if specstream
	  (output-file specstream spectitle nil)
	  (with-open-file (str (output-spec exercise)
			   :direction :output :if-exists :supersede
			   :if-does-not-exist :create)     
	    (output-file str spectitle nil)))
      
      ;; write out the output solution file
      (if solnstream
	  (output-file solnstream solntitle nil)
	  (with-open-file (str (output-soln exercise)
			   :direction :output :if-exists :supersede
			   :if-does-not-exist :create)     
	    (output-file str solntitle t))))))



;;; a function which creates output files for all exercises currently
;;; defined

(defun output-all-exercises-standalone-html ()
  (map-exercises #'output-exercise-standalone-html))
    
    
;;; a function which creates two output files which are indices to
;;; standalone output files, two per exercise; sorted according to
;;; fields in sort keyword, using select-exercises

(defun output-all-exercise-indices (&key (sort-fields '(name))
					 (basename-with-solutions
					  "index-with-solutions")
					 (basename-without-solutions
					  "index-without-solutions")
					 (pathname->url-function
					  #'(lambda (p)
					      ;; This is a hack.
					      (concatenate 'string
						(pathname-name p)
						"."
						(pathname-type p)))))
  (let ((pathname-with-solutions
	 (make-pathname :directory *output-directory*
			:name basename-with-solutions
			:type *html-extension*))
	(pathname-without-solutions
	 (make-pathname :directory *output-directory*
			:name basename-without-solutions
			:type *html-extension*))
	(exlist (sort-exercises (select-exercises (x)) sort-fields)))
    (flet ((genfile (filename title getter)
	     (with-open-file (out filename
			      :direction :output
			      :if-exists ':supersede)
	       (with-html-output (out)
		 (:html
		  (:head 
		   (:title title))
		  (:body
		   (:h1 title)
		   (:table
		    (:tbody
		     (:tr 
		      (:th "Name")
		      (:th "Difficulty"))
		     (lfd)
		     (dolist (ex exlist)
		       (htm 
			(:tr
			 (:td ((:a :href (funcall pathname->url-function
						  (funcall getter ex)))
			       (fmt "~A" (name ex))))
			 (:td (fmt "~A" (difficulty ex))))
			(lfd)))))))))))
      (genfile pathname-without-solutions
	       "Index to all exercise specifications"
	       #'output-spec)
      (genfile pathname-with-solutions
	       "Index to all exercise specifications with solutions"
	       #'output-soln))))


      
	  

;;; next
  
;;; a function which creates two output files containing all exercises;
;;; one with solutions, one without, sorted according to fields in sort
;;; key

(defun output-all-exercises-one-file (&key (sort-fields '(name))
					   (basename-with-solutions
					    "all-exercises-with-solutions")
					   (basename-without-solutions
					    "all-exercises-without-solutions"))
  (let ((pathname-with-solutions
	 (make-pathname :directory *output-directory*
			:name basename-with-solutions
			:type *html-extension*))
	(pathname-without-solutions
	 (make-pathname :directory *output-directory*
			:name basename-without-solutions
			:type *html-extension*))
	(exlist (sort-exercises (select-exercises (x)) sort-fields)))
    (flet ((genfile (filename title solutions-p)
	     (with-open-file (out filename
			      :direction :output
			      :if-exists ':supersede)
	       (with-html-output (out)
		 (:html
		  (:head 
		   (:title title))
		  (:body
		   (:h1 title)
		   (dolist (ex exlist)
		     (output-exercise-as-html ex out solutions-p)
		     (htm (lfd) (:hr) (lfd)))))))))
      (genfile pathname-without-solutions
	       "All exercises"
	       nil)
      (genfile pathname-with-solutions
	       "All exercises with solutions"
	       t))))