;;; CMSC 421, answers to Project 1
;;; Dana Nau, October 1, 2008


;;; ---------------------------------------------------------------------
;;; Problem 1: SUBSETS3-LOOPING, two different versions
;;; ---------------------------------------------------------------------

;;; Below are two different versions (suffixed with -V1 and -V2)
;;; Both of them use three nested loops to iterate over all three-tuples.
;;; One uses DO to do this, and the other uses LOOP.

(defun subsets3-looping-v1 (s)
  (let (result)
    ;; Iterate by taking successive sublists.
    ;; In each iteration, the 1st element of the triple is the CAR of the sublist.
    (do ((x s (cdr x)))
	((null x) result)
      ;; Y starts at (CDR X) so that the 1st and 2nd elements of the triple will differ
      (do ((y (cdr x) (cdr y)))
	  ((null y) nil)
	;; Z starts at (CDR Y) for a similar reason
	(do ((z (cdr y) (cdr z)))
	    ((null z) nil)
	  (push (list (car x) (car y) (car z)) result))))))

(defun subsets3-looping-v2 (x)
  (let* (result y z)
    ;; just like Version 1, but uses LOOP instead of DO
    (loop while x do
	  (setq y (cdr x))
	  (loop while y do
		(setq z (cdr y))
		(loop while z do
		      (push (list (car x) (car y) (car z)) result)
		      (setq z (cdr z)))
		(setq y (cdr y)))
	  (setq x (cdr x)))
    result))


;;; ---------------------------------------------------------------------
;;; Problem 2: SUBSET3-MAPPING
;;; ---------------------------------------------------------------------

;;; Version 1
;;; Basic idea: iterate over each combination of X, Y, and Z such that (X Y Z) is a subset of S.
;;; We do this by taking successive CDRs, hence the use of MAPLIST and MAPCON
;;; We get X and Y and Z by taking CARS of those CDRS
;;;
;;; I've done this using unnamed LAMBDA functions, but it would also be
;;; possible to DEFUN them as auxiliary functions, and call them by name

(defun subsets3-mapping-v1 (s)
  ;; iterate over X, and concatenate the list of triples returned by MAPCON below  
  (mapcon
   (lambda (x)
     ;; given X, iterate over Y and concatenate the lists returned by MAPLIST below
     (mapcon
      (lambda (y)
	(maplist
	 ;; given X and Y, iterate over Z and return a list of triples (X Y Z)
	 (lambda (z) (list (car x) (car y) (car z)))
	 (cdr y)))
      (cdr x)))
   s))

;;; Version 2 iterates in the same way that Version 1 does, but this time we
;;; don't use the values returned by the mapping functions.  Instead, the innermost
;;; LAMBDA is executed only for its side-effect.
;;; Both versions should have the same big-O running time, but this version should have
;;; more overhead because it's building up two different lists: the one that we're explicitly
;;; storing in RESULT, and the one built by the mapping functions from the returned values of
;;; the LAMBDA expressions.  The latter is ignored and will get garbage-collected.
;;; If Allegro has a good enough optimizing compiler, it might be able to detect that the
;;; lists created by the mapping functions are ignored, and not bother creating them at all,
;;; but I don't know whether does this or not.

(defun subsets3-mapping-v2 (s)
  (let (result)
    (maplist
     (lambda (x)
       ;; given X, iterate over Y and concatenate the lists returned by MAPLIST below
       (maplist
	(lambda (y)
	  (maplist
	   ;; given X and Y, iterate over Z and return a list of triples (X Y Z)
	   (lambda (z)
	     (push (list (car x) (car y) (car z)) result))
	   (cdr y)))
	(cdr x)))
     s)
    result
    ))


;;; ---------------------------------------------------------------------
;;; Problem 3: SUBSETS3-RECURSIVE, two different versions
;;; ---------------------------------------------------------------------
 
;;; First Version

(defun subsets3-recursive-v1 (s)
  ;; call SUBSETS2-RECURSIVE to get all 2-ary subsets of (CDR S),
  ;; and cons (CAR S) onto the front of each of them
  (if
      (null s)
      nil
    (append
     (splice (car s) (subsets2-recursive-v1 (cdr s)))
     (subsets3-recursive-v1 (cdr s)))))

(defun subsets2-recursive-v1 (s)
  ;; call SUBSETS1-RECURSIVE-V1 to get all 1-ary subsets of (CDR S),
  ;; and cons (CAR S) onto the front of each of them
  (if
      (null s)
      nil
    (append
     (splice (car s) (subsets1-recursive-v1 (cdr s)))
     (subsets2-recursive-v1 (cdr s)))))

(defun subsets1-recursive-v1 (s)
  ;; recursively construct a list of all 1-ary subsets of S
  (if
      (null s)
      nil
    (cons (list (car s)) (subsets1-recursive-v1 (cdr s)))))

(defun splice (item list)
  ;; this function does the CONSing needed by the above three functions
  (if (null list)
      nil
    (cons (cons item (car list))
	  (splice item (cdr list)))))

;;; Version 2

;;; This version works in the same way as SUBSETS3-LOOPING and SUBSETS3-MAPPING,
;;; but replaces the loops with recursive calls.  The higher-level functions pass
;;; the current values of X and Y down to SUBSETS1-RECURSIVE-V2, which selects
;;; Z and conses the list (X Y Z) onto the result that it's building up.  This
;;; avoids the APPEND that we used in Version 1, which might give it have a faster
;;; big-O running time (I'm not sure), but is a lot messier because of all the
;;; auxiliary variables that it passes around.

(defun subsets3-recursive-v2 (s)
  ;; call SUBSETS2-RECURSIVE-V2 to get all 2-ary subsets of (CDR S),
  ;; and cons (CAR S) onto the front of each of them
  (if
      (null s)
      nil
    (let ((result (subsets3-recursive-v2 (cdr s))))
      (subsets2-recursive-v2 (cdr s) (car s) result))))

(defun subsets2-recursive-v2 (s x result-so-far)
  ;; call SUBSETS1-RECURSIVE to get all 1-ary subsets of (CDR S),
  ;; and cons (CAR S) onto the front of each of them
  (if
      (null s)
      result-so-far
    (let ((result (subsets2-recursive-v2 (cdr s) x result-so-far)))
      (subsets1-recursive-v2 (cdr s) x (car s) result))))

(defun subsets1-recursive-v2 (s x y result-so-far)
  ;; recursively construct a list of all 1-ary subsets of S
  (if
      (null s)
      result-so-far
    (cons 
     (list x y (car s))
     (subsets1-recursive-v2 (cdr s) x y result-so-far))))


;;; ---------------------------------------------------------------------
;;; Problem 4: SUBSETS, two different versions
;;; ---------------------------------------------------------------------

;;; Version 1: combine recursion and mapping
(defun subsets-v1 (s n)
  (cond ((= n 0) (list nil))		; If N=0, there's exactly one subset: the empty set
	((null s) nil)			; Else if S is empty then there are no subsets at all
	;; below, the APPEND is unfortunate because it increases the big-O running time
	(t (append
	    ;; first, cons (CAR S) onto every n-1-ary subset of (CDR S)	    
	    (mapcar
	     (lambda (item) (cons (car s) item))
	     (subsets-v1 (cdr s) (- n 1)))
	    ;; second, recursively compute all n-ary subsets of (CDR S)
	    (subsets-v1 (cdr s) n)))))

;;; Version 2: is like version 1 except that the 1st and 2nd steps are done in the opposite order
;;; this  allows us to avoid doing the APPEND
(defun subsets-v2 (s n)
  (cond ((= n 0) (list nil))		; If N=0, there's exactly one subset: the empty set
	((null s) nil)			; Else if S is empty then there are no subsets at all
	;; Below, I could interchange the 1st and 2nd steps and still get an equivalent result
	(t
	 ;; first, recursively compute all n-ary subsets of (CDR S)
	 (let ((result (subsets-v1 (cdr s) n)))
	   ;; Second, cons (CAR S) onto every n-1-ary subset of (CDR S)
	   ;; We invoke MAPCAR to produce a side-effect, and ignore the value it returns
	   ;; We could get the exact same behavior using a loop instead of MAPCAR
	   (mapcar
	    (lambda (item) (push (cons (car s) item) result))
	    (subsets-v1 (cdr s) (- n 1)))
	   result))))

;;; Version 3: nearly identical to Version 2, but uses a loop instead of MAPCAR
(defun subsets-v3 (s n)
  (let (result)
    (cond ((= n 0) (list nil))
	  ((null s) nil)
	  (t
	   ;; first, recursively compute all n-ary subsets of (CDR S)
	   (setq result (subsets-v2 (cdr s) n))
	   ;; second, cons (CAR S) onto every n-1-ary subset of (CDR S)
	   (dolist (item (subsets-v2 (cdr s) (- n 1)))
	     (push (cons (car s) item) result))
	   result))))


;;; ---------------------------------------------------------------------
;;; Problem 5: MERGE-SORT
;;; ---------------------------------------------------------------------

(defun merge-sort (seq pred n1 n2)
  (if (< (- n2 n1) 2)
      ;; if seq contains < 2 elements then no sorting is needed
      seq
    (let ((mid (floor (/ (+ n1 n2) 2)))) ; mid = approximate half-way point
      (merge-sort seq pred n1 mid)
      (merge-sort seq pred mid n2)
      (my-merge seq pred n1 mid n2))))

(defun my-merge (sequence pred bottom middle top)
  (let
      ;; FOO is a copy of what we're going to sort. Without a copy, we'd lose
      ;; track of what we're doing when SEQUENCE gets overwritten.
      ;; x1 and top1 are the bottom and top of the 1st half,
      ;; x2 and top2 are the bottom and top of the 2nd half,
      ;; WHICH tells which element to take next,
      ;; and INDEX tells where to put it
      ((foo (subseq sequence bottom top))
	(x1 0)
	(top1 (- middle bottom))
	(x2 (- middle bottom))
	(top2 (- top bottom))
	(index bottom)
	which)

    (loop
      (cond		       ; choose which element goes next
       ((>= index top) (return sequence)) ; we've merged everything => done
       ((>= x1 top1) (setq which 2)) ; 1st half empty => take from 2nd half
       ((>= x2 top2) (setq which 1)) ; 2nd half empty => take from 1st half
       ;; both halves nonempty => take the next element from the
       ;; 2nd half if it's smaller, otherwise from the 1st half
       ((funcall pred (elt foo x2) (elt foo x1)) (setq which 2))
       (t (setq which 1)))
      
      ;; now, copy our chosen element from FOO into SEQUENCE
      (cond ((= which 1)
	     (setf (elt sequence index) (elt foo x1))
	     (setq x1 (+ 1 x1))
	     (setq index (+ 1 index)))
	    (t (setf (elt sequence index) (elt foo x2))
	       (setq x2 (+ 1 x2))
	       (setq index (+ 1 index)))))))


;;; here's some test data for merge-sort:

; (print (setq s '(1 3 4 6 7 2 5 8)))
; (print (my-merge s #'< 0 5 8))

; (print (setq s '(1 3 4 6 7 2 5 8)))
; (print (merge-sort s #'< 0 8))

; (print (setq s #(1 3 4 6 7 2 5 8)))
; (print (merge-sort s #'< 0 8))

; (print (setq s "13467258"))
; (print (merge-sort s #'char< 0 8))



;;; ---------------------------------------------------------------------
;;; PROBLEM 6: MATHPRINT
;;; ---------------------------------------------------------------------

(defun mathprint (expr)
  (format t "~%")			; make sure we're on a new line
  (mathprint1 expr))

(defun mathprint1 (expr)
  (cond ((atom expr)			; in this case, the expression is a variable or constant
	 (format t "~s" expr))
	(t (format t "~s(" (car expr))	; print the function name
	   (if (cdr expr)		; print the args, if there are any
	       (mathprint-args (cdr expr))) 
	   (format t ")"))))

(defun mathprint-args (arglist)
  ;; arglist should be a *non-empty* list of arguments
  (mathprint1 (car arglist))
  (if (cdr arglist)
      (progn (format t ", ")
	     (mathprint-args (cdr arglist)))))