;;;
;;; MNFIT215 Functional Programming (Lisp)
;;;
;;; Assignment #3 (due 1999-11-01)
;;;
;;; Vebjørn Ljoså <ljosa@pvv.ntnu.no>, 3. data 
;;; Homework group #1 -- leader: Geir Tjørhom <geirtj@ifi.ntnu.no>
;;;


;;;
;;; Exercise 1
;;;

;; Exercise 1a

(defmacro /. (a b)
  `(/ (float ,a) (float ,b)))

(macroexpand-1 `(/. 3 5))
;; (/ (FLOAT 3) (FLOAT 5))
;; T
(/. 3 5)
;; 0.6


;; Exercise 1b

(defmacro root (x n)
  `(expt ,x (/ 1 ,n)))

(macroexpand-1 '(root x n))
;; (EXPT X (/ 1 N))
;; T
(root 27 3)
;; 3.0


;; Exercise 1c

(defmacro ln (x)
  `(log ,x))

(macroexpand-1 '(ln 42))
;; (LOG 42)
;; T
(ln 42)
;; 3.7376697


;;;
;;; Exercise 2
;;;

;; Exercise 2a

(defmacro my-delete (x elems)
  `(setf ,elems (delete ,x ,elems)))	; XXX: gensym?

(setf elems '(a b c))
(macroexpand-1 '(my-delete 'b elems))
;; (SETF ELEMS (DELETE 'B ELEMS))
;; T
(my-delete 'b elems)
;; (A C)


;; Exercise 2b

(defmacro my-nreverse (elems)
  `(setf ,elems (nreverse ,elems)))	; XXX: gensym necessary?

(setf elems '(a b c))
(macroexpand-1 '(my-nreverse elems))
;; (SETF ELEMS (NREVERSE ELEMS))
;; T
(my-nreverse elems)
;; (C B A)


;; Exercise 2c

(defmacro swap (x y)
  "swaps X and Y, and returns the new X and Y as a list"
  (let ((temp (gensym)))
    `(progn
       (setf temp x)
       (setf x y)
       (setf y temp)
       (list x y))))

(macroexpand-1 `(swap x y))
;; (PROGN (SETF TEMP X) (SETF X Y) (SETF Y TEMP) (LIST X Y))
;; T
(let ((x 42) (y 43)) 
  (swap x y))
;; (43 42)


;;;
;;; Exercise 3
;;;

(defmacro with-random-int ((x lower upper) &rest body)
  `(let ((,x (+ ,lower (random (1+ (- ,upper ,lower))))))
     ,@body))

(macroexpand-1 '(with-random-int (r 5 10) (print r) (print (* 10 r))))
;; (LET ((R (+ 5 (RANDOM (1+ (- 10 5)))))) (PRINT R) (PRINT (* 10 R)))
;; T
(with-random-int (r 5 10) 
  (print r) 
  (print (* 10 r)))
;; 8 
;; 80
;; 80  ; returned value


;;;
;;; Exercise 4
;;;

;; Exercise 4a

(defun seq-pairs (elems)
  (subseq (maplist #'(lambda (l) 
		       (list (first l) (second l))) 
		   elems)
	  0 (1- (length elems))))

(seq-pairs '(a b c d))
;; ((A B) (B C) (C D))


;; Exercise 4b

(defun wrapped-seq-pairs (elems)
  (let ((argh (maplist #'(lambda (l) (list (first l) (second l))) elems)))
    (setf (cdr (car (last argh 1))) (list (car elems))) ; XXX: ugly
    argh))

(wrapped-seq-pairs '(a b c d)) 
;; ((A B) (B C) (C D) (D A))


;;;
;;; Exercise 5
;;;

;; Exercise 5a

(defmacro swap-left (&rest vars)
  `(psetf ,@(apply #'nconc (wrapped-seq-pairs vars))))
 
(macroexpand-1 '(swap-left x y z))
;; (PSETF X Y Y Z Z X)
;; T

(setf x 1 y 2 z 3)
;; 3
(swap-left x y z)
;; NIL
(list x y z)
;; (2 3 1)


;; Exercise 5b

(defmacro swap-right (&rest vars)
  `(swap-left ,@(reverse vars)))

(macroexpand-1 '(swap-right x y z))
;; (SWAP-LEFT Z Y X)
;; T
(macroexpand-1 '(swap-left z y x))
;; (PSETF Z Y Y X X Z)
;; T

(setf x 1 y 2 z 3)
;; 3
(swap-right x y z)
;; NIL
(list x y z)
;; (3 1 2)


;;;
;;; Exercise 6
;;;

(defmacro dotimes-countdown ((var end-val &optional return-val) &rest body)
  `(let ((g (gensym)))
     (dotimes (g ,end-val ,return-val)
       (let ((,var (- ,end-val g 1)))
	 ,@body))))

(macroexpand-1 '(dotimes-countdown (k 5 "Done")
		 (format t "~A" k)))
;; (LET ((G (GENSYM)))
;;   (DOTIMES (G 5 "Done") (LET ((K (- 5 G 1))) (FORMAT T "~A" K))))
;; T

(dotimes-countdown (k 5 "Done")
		   (format t "~A" k))
;; 43210


;;;
;;; Exercise 7
;;;

(defmacro counter-dolist ((elem elems counter-var &optional return-var) &rest body)
  `(let ((,counter-var 0))
     (dolist (,elem ,elems ,return-var)
       ,@body
       (incf ,counter-var))))

(macroexpand-1 '(counter-dolist (x '(a b c d) index "done") 
		 (print (list index x))))
;; (LET ((INDEX 0))
;;   (DOLIST (X '(A B C D) "done") (PRINT (LIST INDEX X)) (INCF INDEX)))
;; T

(counter-dolist (x '(a b c d) index "done") 
		(print (list index x)))
;; (0 A) 
;; (1 B) 
;; (2 C) 
;; (3 D) 


;;;
;;; Exercise 8
;;;

(defmacro def-memofun (funcname (&rest argsvar) &rest body)
  (let ((memotable (gensym "MEMOTABLE"))
	(value (gensym "VALUE"))
	(found (gensym "FOUND")))
    `(let ((,memotable (make-hash-table :test #'equal)))
       (defun ,funcname ,argsvar
	 (multiple-value-bind (,value ,found) (gethash ,argsvar ,memotable)
	   (if ,found
	       ,value
	     (setf (gethash ,argsvar ,memotable)
	       (progn
		 ,@body))))))))
(macroexpand-1 '(def-memofun my-sleep (time retval) 
		 (sleep time)
		 retval))
;; (LET ((#:MEMOTABLE154 (MAKE-HASH-TABLE :TEST #'EQUAL)))
;;   (DEFUN MY-SLEEP (TIME RETVAL)
;;     (MULTIPLE-VALUE-BIND (#:VALUE155 #:FOUND156)
;;         (GETHASH (TIME RETVAL) #:MEMOTABLE154)
;;       (IF #:FOUND156
;;           #:VALUE155
;;         (SETF (GETHASH (TIME RETVAL) #:MEMOTABLE154)
;;               (PROGN (SLEEP TIME) RETVAL))))))
;; T

(def-memofun my-sleep (time retval) 
  (sleep time)
  retval)
;; MY-SLEEP
(time (my-sleep 2 1))
; cpu time (non-gc) 0 msec user, 0 msec system
; cpu time (gc)     0 msec user, 0 msec system
; cpu time (total)  0 msec user, 0 msec system
; real time  0 msec
; space allocation:
;  0 cons cells, 0 symbols, 0 other bytes, 0 static bytes
; cpu time (non-gc) 0 msec user, 0 msec system
; cpu time (gc)     0 msec user, 0 msec system
; cpu time (total)  0 msec user, 0 msec system
; real time  0 msec
; space allocation:
;  0 cons cells, 0 symbols, 0 other bytes, 0 static bytes
; cpu time (non-gc) 16 msec user, 0 msec system
; cpu time (gc)     0 msec user, 0 msec system
; cpu time (total)  16 msec user, 0 msec system
; real time  2,015 msec
; space allocation:
;  574 cons cells, 3 symbols, 1,536 other bytes, 0 static bytes
;; 1
(time (my-sleep 2 2))
; cpu time (non-gc) 0 msec user, 0 msec system
; cpu time (gc)     0 msec user, 0 msec system
; cpu time (total)  0 msec user, 0 msec system
; real time  0 msec
; space allocation:
;  0 cons cells, 0 symbols, 0 other bytes, 0 static bytes
; cpu time (non-gc) 0 msec user, 0 msec system
; cpu time (gc)     0 msec user, 0 msec system
; cpu time (total)  0 msec user, 0 msec system
; real time  0 msec
; space allocation:
;  0 cons cells, 0 symbols, 0 other bytes, 0 static bytes
; cpu time (non-gc) 15 msec user, 0 msec system
; cpu time (gc)     0 msec user, 0 msec system
; cpu time (total)  15 msec user, 0 msec system
; real time  2,017 msec
; space allocation:
;  572 cons cells, 3 symbols, 1,536 other bytes, 0 static bytes
;; 2
(time (my-sleep 2 1))
; cpu time (non-gc) 8 msec user, 0 msec system
; cpu time (gc)     0 msec user, 0 msec system
; cpu time (total)  8 msec user, 0 msec system
; real time  0 msec
; space allocation:
;  0 cons cells, 0 symbols, 0 other bytes, 0 static bytes
; cpu time (non-gc) 8 msec user, 0 msec system
; cpu time (gc)     0 msec user, 0 msec system
; cpu time (total)  8 msec user, 0 msec system
; real time  5 msec
; space allocation:
;  273 cons cells, 0 symbols, 760 other bytes, 0 static bytes
;; 1


;;;
;;; Exercise 9
;;;

(defmacro with-gensyms (syms &body body)
  `(let ,(mapcar #'(lambda (s)
		     `(,s (gensym)))
	  syms)
     ,@body))

(defmacro n-of (n &rest body)
  (with-gensyms (i l)
    `(let ((,l nil))
       (dotimes (,i ,n (nreverse ,l))
	 (push (progn ,@body) ,l)))))

(let ((i 0))
  (macroexpand-1 '(n-of 4
		   (incf i))))
;; (LET ((#:G253 NIL))
;;   (DOTIMES (#:G252 4 (NREVERSE #:G253)) (PUSH (PROGN (INCF I)) #:G253)))
;; T
(let ((i 0) (n 4))
  (n-of n
	(incf i)))
;; (1 2 3 4)
(let ((x 2)) 
  (macroexpand-1 '(n-of 6 (setf x (expt x 2)))))
;; (LET ((#:G257 NIL))
;;   (DOTIMES (#:G256 6 (NREVERSE #:G257))
;;     (PUSH (PROGN (SETF X (EXPT X 2))) #:G257)))
;; T
(let ((x 2)) 
  (n-of 6 (setf x (expt x 2))))
;; (4 16 256 65536 4294967296 18446744073709551616)


;;;
;;; Exercise 10
;;;

(defmacro setvars-from-list (vars list)
  `(multiple-value-setq ,vars (apply 'values ,list)))

(defmacro reset-protect (vars &rest body)
  (let ((save (gensym))
	(retval (gensym)))
    `(progn
       (let ((,save (list ,@vars)))
	 (let ((,retval (progn ,@body)))
	   (setvars-from-list ,vars ,save)
	   ,retval)))))

(macroexpand-1 '(reset-protect (x y z)
		 (setf x 555 y 666 z 777)
		 (list x y z)))
;; (PROGN (LET ((#:G316 (LIST X Y Z)))
;;          (LET ((#:G317 (PROGN (SETF X 555 Y 666 Z 777) (LIST X Y Z))))
;;            (SETVARS-FROM-LIST (X Y Z) #:G316)
;;            #:G317)))
;; T
(setf x 100 y 200 z 300)
;; 300
(reset-protect (x y z)
	       (setf x 555 y 666 z 777)
	       (list x y z))
;; (555 666 777)
(list x y z)
;; (100 200 300)


;;;
;;; end of MNFIT215 assignment #3
;;;