utilities.lisp~

;;;; utilities.lisp

(in-package #:utilities)

;;; "utilities" goes here. Hacks and glory await!

(eval-when (:compile-toplevel :load-toplevel :execute)
  ;soon as compiliation of utilities occurs use infix math in whatever lib
  ;invokes it
 

  (defmacro set! 
      (&rest vars) 
    (cons 'progn 
	  (loop for v in (partition vars 2)  
	     collect `(setf ,@v))))
  
  (defun nil? (val)
    (eq nil val))


  (defun in?    ;TODO will not work for all data structures need a better solution
      (coll val)
    (member val coll))

  (defun make-vector () 
    (make-array 5 :fill-pointer 0 :adjustable t))


  (defun filter (pred list) 
    (loop for elm in list 
       when (funcall pred elm) 
       collect elm))

  (defmacro if-not (bool true &optional (false nil))
    `(if (not ,bool) ,true ,false))

					;TODO need to make first work on every seqable structure!
  (defparameter lisp-first #'first)
  (defparameter lisp-map #'map)

  (defgeneric 1st (seq))

  (defmethod 1st ((str string))
    (char str 0))

  (defmethod 1st ((lst cons))
    (funcall lisp-first lst))

  (defmethod 1st ((coll null))
    (funcall lisp-first coll))

  (defmethod 1st ((coll vector))
    (if-not (= (length coll)
	       0)
	    (aref coll 0)
	    nil))


					;(fmakunbound 'imap) just in case you need to redifine a generic fn

  (defgeneric imap (fn coll))

  (defmethod imap ((fn function) (coll vector))
    (loop
       with length = (length coll)
       with array = (make-array length)
       for i upto (1- length)
       do (setf (aref array i) (funcall fn (aref coll i)))
       finally (return array)))


  (defgeneric for-each (coll fn))

  (defmacro fn (args &body body)
    `(lambda ,args ,@body))

  (defmethod for-each ((coll vector) (fn function))
    (loop
       with length = (length coll)
       for i upto (1- length)
       do (setf (aref coll i) (funcall fn (aref coll i)))
       finally (return coll)))

  (defun flatten (x)
    (labels ((rec (x acc)
	       (cond ((null x) acc)
		     ((atom x) (cons x acc))
		     (t (rec
			 (car x)
			 (rec (cdr x) acc))))))
      (rec x nil)))
  
  (defun ask (string)
    (princ string *query-io*)
    (read *query-io*))
  
  (defun to-string (&rest args)
    (apply #'concatenate 
	   'string 
	   (loop for i in args 
	      collect  (if (stringp i) 
			   i 
			   (write-to-string i)))))
  
  (defun to-symbol (str) (intern (string-upcase str)))

  (defun to-keyword (name) 
    (values (intern (string-upcase name) "KEYWORD")))
  
  (defun partition (source n)
    (if (zerop n) (error "zero length"))
    (labels ((rec (source acc)
	       (let ((rest (nthcdr n source)))
		 (if (consp rest)
		     (rec rest (cons
				(subseq source 0 n)
				acc))
		     (nreverse
		      (cons source acc))))))
      (if source (rec source nil) nil)))
  
  (defun slots-of (obj) (gethash obj *class-slots*))

  (defun gen-slots (slots)
    (restart-case 
	(if (not (evenp (length slots)))
	    (error "Not all slots have been assigned a value!")
	    (loop for (a b) in (partition slots 2)
	       collect `(,a
			 :initarg  ,(to-keyword a) 
			 :initform ,b 
			 :accessor ,a)))
      (use-value (value)
	:report "Create a new slot list"
	:interactive (lambda () (list (ask "Value: ")))
	(gen-slots value))))
  
  
  (defmacro def-generic (name args) 
    (fmakunbound name) ;makes sure that this can be redifined!
    `(defgeneric ,name 
	 ,(append args))) ; '(&key)
  
  (defun append-obj-slots 
      (obj-list)
    (partition (flatten (loop for (var obj) in obj-list 
			   collect (if (eq obj nil) 
				       nil 
				       (loop for slot in (slots-of obj) 
					  collect (list (to-symbol (to-string var "-" slot)) 
							slot))))) 
	       2))


					;
					;(loop with x = 1 
					;      with new-list = (first test) 
					;      while (< x (length test)) 
					;            do (progn 
					;                 (setf new-list (append new-list (list (nth x test))))  
					;                 (setf x (1+ x)) 
					;      finally (return new-list))) 

  (defun create-with-accessor-for-obj 
      (obj) 
    `(with-accessors ,(loop for slot in (slots-of obj) 
			 collect (list (to-symbol (to-string obj "-" slot)) 
				       slot)) 
	 ,obj))

  (defun create-with-accessor-for-overrides-and-setters 
      (obj) 
    `(with-accessors ,(loop for slot in (slots-of obj) 
			 collect (list slot 
				       slot)) 
	 ,obj))

  (defmacro override-getter 
      (name obj code)
    `(defmethod ,name 
	 (,(list obj obj)) 
       ,(reverse (cons code 
		       (reverse (create-with-accessor-for-overrides-and-setters obj))))))
  (defmacro override-setter 
      (name obj value code)
    `(defmethod (setf ,name) 
	 (,value ,(list obj obj)) 
       ,(reverse (cons code 
		       (reverse (create-with-accessor-for-overrides-and-setters obj))))))

  (defun make-accessor-args
      (obj-list)
    "takes an argument list that would normally
   go to the defmethod function...
   '((point1 one) (point2 two))
   it then obtains the slots of the objects that defmethod dispatches on
   assuming one and two are points...
   ((x y) (x y))
   it then takes these slots and matches them with their object like so...
   ((WITH-ACCESSORS ((POINT1-X X) (POINT1-Y Y)) ONE)
    (WITH-ACCESSORS ((POINT2-X X) (POINT2-Y Y)) TWO) NIL)"
    (loop for (var obj) in obj-list 
       collect (cond ((eq obj nil)
		      nil)
		     ((gethash obj *mixins*)
		      `(with-accessors
			     ,(loop for slot in (gethash obj mixin-dependencies) 
				 collect (list (to-symbol (to-string var "-" slot)) 
					       slot)) 
			     ,var))
		     (:default
		      `(with-accessors ,(loop for slot in (slots-of obj) 
					   collect (list (to-symbol (to-string var "-" slot)) 
							 slot)) 
			     ,var))))) 
  

 

  (defun place-method-at-the-end-of-with-accessors
      (with-accessor-list body)
    (let* ((code  (filter (lambda (x) (not (eq x nil))) 
			  with-accessor-list))
	   (last-code (loop with last-code = (first (last code))
			 for code in body 
			 do (setf last-code (append last-code (list code))) 
			 finally (return last-code)))
	   (code (append (butlast code) 
			 (list last-code)))) 
      code))

  (defun nest-with-accessors 
      (with-accessor-list)
    "takes a list such as the one above ^ ...
  ((WITH-ACCESSORS ((POINT1-X X) (POINT1-Y Y)) ONE)
    (WITH-ACCESSORS ((POINT2-X X) (POINT2-Y Y)) TWO) NIL)
  and nests the with-accessors together like so...
  (WITH-ACCESSORS ((POINT1-X X) (POINT1-Y Y))
                ONE
                (WITH-ACCESSORS ((POINT2-X X) (POINT2-Y Y)) TWO (NIL)))
  the nil at the end does not matter..." 
    (if (not (= (length with-accessor-list) 1)) 
	(append (first with-accessor-list) 
		(list (nest-with-accessors (rest with-accessor-list))))
	(first with-accessor-list)))



  (defmacro def-method ;;TODO make these work differently with mixins, need to extract data deps for with accessors and possible constructor will need luv
      (name args &rest body)
    (let ((unroll nil)
	  (find-objects (loop for elm in args when (consp elm) collect elm)))
      (if (not (nil? find-objects)) 
	  (setf unroll (list (nest-with-accessors (place-method-at-the-end-of-with-accessors (make-accessor-args find-objects) 
											       body))))
	  (setf unroll body))
      `(defmethod ,name 
	         ,args 
	         ,@unroll)))

  (def-generic attach (coll &optional key value))

  (def-method attach ((coll hash-table) &optional key value)
    (if-not (and key value)
	    (error "A value and key must be supplied to the method attach when invoked on a map")
	    (setf (gethash key coll) 
		  value)))
  
  (def-method attach ((coll vector) &optional value key)
    (cond ((and value key)
	   (error "attach takes 2 arguements when applied to vectors, not 3"))
	  ((nil? value)
	   (error "A value must be supplied to the method attach"))
	  (:default
	   (vector-push-extend value coll))))

  (def-method attach ((coll cons) &optional value pos)
    (cond ((nil? value) 
	   (error "A value must be supplied to the method attach"))
	  ((and value pos)
	   (push value (cdr (nthcdr pos coll)))
	   coll)
	  (:default
	   (push value (cdr (nthcdr 0 coll)))
	   coll)))



  (defun combine-slots (classes)
    (remove-duplicates 
     (flatten 
      (loop for class in classes collect (slots-of class)))))

  (defun grab-slots (slots)
    (loop for (a b) in (partition slots 2) collect a))

  (defun grab-slots-with-accessors (slots)
    (loop for slot in slots collect (list slot slot)))

  ;printer-base is an object that ecery object derives from
  ;it will ensure that all object created by def-class are printed much readable
  (defclass printer-base () ())

  ;print-object makes all objects of the type printer-base print more readable
  (defmethod print-object ((object printer-base) stream)
    (format stream
	    "Object: ~A :slots ~A"
	    (name object)
	    (interleave (slots-of (name object))
			(loop for slot in (slots-of (name object))
			   collect (funcall slot object)))))
  
  (defmacro def-class
      (name &key extends slots constructor super-args)

    (setf extends (append extends '(printer-base)))
    
    (let ((def-method-code nil))
      (if constructor
	  (if (eq (first constructor) 'lambda)
	      nil
	      (error "constructor must be a lambda expression")))

      (if slots
	  (attach *class-slots* 
		  name 
		  (remove-duplicates (append (combine-slots extends) 
					     (grab-slots slots)))))
      
      ;check for mixin dependency problems
      (let ((missing-deps (make-hash-table))
	    (mixins-that-need-deps '()))
	
	(loop for mixin in extends 
	   when (gethash mixin *mixins*)
	   do (loop for dep in (fetch mixin-dependencies mixin)
		 do (if-not (in? (slots-of name) dep) 
			    (if (gethash mixin missing-deps)
				(setf (gethash mixin missing-deps) (remove-duplicates (cons dep (gethash mixin missing-deps))))
				(progn
				  (setf mixins-that-need-deps (cons mixin mixins-that-need-deps)) 
				  (setf (gethash mixin missing-deps) (cons dep '())))))))
        
	(if mixins-that-need-deps
	    (error (loop with error-string = "" 
		      for mixin in mixins-that-need-deps 
		      do (setf error-string 
			       (concatenate 'string 
					    error-string 
					    (to-string "~%" 
						       "mixin: " 
						       mixin 
						       " depends on "
						       (fetch missing-deps mixin)
						       " which is absent from: "
						       name))) 
		      finally (return error-string)))))
      
      (let* ((constructor-args (first (rest constructor)))
	     (constructor-requirements constructor-args))

	(loop for arg in constructor-args
	     do (loop for slot in slots
		when (eq slot arg)
		  do (error (format nil "The slot: ~A and constructor arguement: ~A should not have the same symbol!" slot arg))))

	
	
	(loop for class in extends 
	   do (loop for arg in constructor-args 
		 do (if (in? (slots-of class) arg)
			(warn (to-string "slot: " arg " belonging to class: " class " is being shadowed by constructor arg: " arg)))))
	
	(setf def-method-code 
	      `(defmethod initialize-instance
		   :after
		   ((obj ,name) &key ,@constructor-args)
		 (with-accessors ,(loop for (i _) in (grab-slots-with-accessors (slots-of name))
				     collect (list i i)) 
		     obj 
		   ,@(cddr constructor)
		   (when (next-method-p)
		     ,(if super-args `(call-next-method obj ,@super-args) `(call-next-method obj))))))

	`(progn

	   (defclass ,name 
	             ,extends 
	             ,(append (gen-slots slots) `((name :initform ',name :reader name :allocation :class))))

	   ,def-method-code

	   ',(setf constructor-args (append constructor-args (slots-of name)))
	   
	   (defmacro ,name
	       (&key ,@constructor-args)
	     
	     (if (fetch *mixins* ',name)
		 (error "This class is a mixin, they cannot be instantiated directly"))

	     (if ',constructor-requirements
		 (if-not (and ,@constructor-requirements)
			 (error (format nil "Please provide the following arguements for the constructor: ~A"
					(loop for arg in ',constructor-requirements
					   collect (loop for a in ',constructor-args
						      when (eq a arg)
						      return arg))))))
	     `(make-instance ',',name
			     ,@(flatten
				(loop
				   for (arg value) in (partition
						       (interleave ',constructor-args
								   (list ,@constructor-args))
						       2)
				   when (not (nil? value)) 
				   collect (list (to-keyword arg) value)))))))))
  




  (defmacro def-mixin 
      (name &key extends slots constructor dependencies super-args)

    (let ((data-deps '()))

      (loop for dep in dependencies
	 do (handler-case (progn (find-class dep)
				 (setf data-deps (append data-deps (slots-of dep))))
	      (simple-error () (setf data-deps (append data-deps `(,dep))))))
      
      (attach *mixins* 
	      name
	      name)
      
      (if dependencies 
	  (attach mixin-dependencies 
		  name
		  (remove-duplicates data-deps)))
     
      `(def-class
	   ,name
	   :extends ,extends
	   :slots ,slots
	   :constructor ,constructor
	   :super-args ,super-args)))

  (defmacro make 
      (obj &rest args)
    (if (fetch *mixins* obj)
	(error "Mixins cannot be instantiated directly"))
    `(make-instance ',obj ,@args))

					;(defmacro def-class (name extends slots &key constructor) 
					;    (setf slots (append slots `(name ,name)))
					;    (attach class-slots 
					;            :key name 
					;            :value (append (combine-slots extends) 
					;                           (grab-slots slots)))
					;    `(progn (defclass ,name 
					;                      ,extends 
					;                      ,(gen-slots name slots))
					;            (defmethod initialize-instance 
					;                       :after 
					;                       ((obj ,name) &key)
					;                       (with-accessors ,(grab-slots-with-accessors slots) obj 
					;                                       ,@constructor))))
					;THIS VERSION DOES NOT WORK TELL DR MEISTER!




					;(let ((counter 0))
					;    (flet ((run-code-with-state (code) 
					;       (progn (setf counter (1+ counter)) code)))
					;      (defmacro new (name &rest args)
					;        `(make-instance ',name 
					;            ,@(mapcar (lambda (x) 
					;            (if (evenp counter)
					;                (run-code-with-state `(quote ,x))
					;                (run-code-with-state x)))    
					;          args)))))



  (def-generic fetch (coll item-to-fetch))

  (def-method fetch ((coll hash-table) k)
    (gethash k coll))

  (defmacro -=
      (var value)
    `(setf ,var (- ,var ,value)))
  (defmacro +=
      (var value)
    `(setf ,var (+ ,var ,value)))

  ;export every symbol in this package
  (let ((pack (find-package :utilities)))
    (do-all-symbols (sym pack) (when (eql (symbol-package sym) pack) (export sym))))
  )