;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -*- 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))))