(in-package :lol)

;;; *********************************************************
;;; ************  Class & Environment Utilities *************
;;; *********************************************************

(defgeneric class-exist-p (symbol)
   (:documentation
    "CLASS-EXIST-P is a LOL function.
Returns t if <symbol> is a class.
<symbol> can be a symbol or a list of symbols."))

(defmethod class-exist-p ((symbol symbol))
   (when (find-class symbol nil)
     t))

(defmethod class-exist-p ((symbol list))
   (mapcar #'class-exist-p symbol))

(defmethod class-exist-p ((symbol t))
   nil)

(defmethod class-exist-p ((symbol null))
   nil)


(defun func-val (symbol)
  (when (fboundp symbol)
    (symbol-function symbol)))


(defun find-generic-function (package)
  "List of generic functions of <package>."
  (let
    ((names-and-gen-fct '()))
    (do-symbols (symbol package)
      (when (eq package (symbol-package symbol))
        (let ((fct-val (function-name (func-val symbol))))
          (when (and fct-val
                     (generic-function-p fct-val))
            (push (list symbol fct-val)
                  names-and-gen-fct)))))
    (mapcar #'second
            (sort names-and-gen-fct
                  #'string-lessp :key #'first))))


#|
(function-name (func-val 'make))
(generic-function-p 'make)
(find-generic-function (find-package 'cl-user))
|#


(defun find-lol-classes (package)
  "List of generic functions of <package>."
  (let
    ((classes '()))
    (do-symbols (symbol package)
      (when (eq package (symbol-package symbol))
        (let ((new-class (find-class symbol nil)))
          (when new-class
            (push (list symbol new-class)
                  classes)))))
    (mapcar #'second
            (sort classes
                  #'string-lessp :key #'first))))

#|
(find-lol-classes (find-package 'cl-user))
|#


(defmethod slots ((class symbol) &key not)
  (let ((slots (mapcar #'car
                       (class-instance-slots (find-class class)))))
    (remove-if #'(lambda (s) (member s not :test #'eql)) slots)))

(defmethod slots ((class t) &key not)
  (let ((slots (mapcar #'car
                       (class-instance-slots (class-of class)))))
    (remove-if #'(lambda (s) (member s not :test #'eql)) slots)))

;(slots 'situation :not '(name))
;(slots (make-instance 'situation))


;;; *********************************************************
;;; **********  MAIN CLASSES definitions  *******************
;;; *********************************************************


(defclass W! ()
  ()
   (:documentation "Class for without.")
   )

(defmethod print-object ((self w!) stream)
  (format stream
          "W!"  )
  (values))

(defvar w! (make-instance 'w!))


(defgeneric w!-p (object)
  (:documentation
   "Tests if <object> is w!."))

(defmethod w!-p ((object t))
  nil)

(defmethod w!-p ((object w!))
  t)

(defmethod w!-p ((object null))
  t)



#|
(w!-p w!)
(w!-p nil)
(w!-p 8)
|#


(defclass DANSER ()
   ((name :initarg :name :initform nil :accessor name :type symbol)
    (color :initarg :color :initform nil :accessor color :type symbol)
    )
   (:documentation "DANSER (LOL class) : Meta class for all dimensions including Laban dimensions.
Slots are :name "))



(defmethod initialize-instance :after ((self danser) &key name)
  
  (let ((name-of-danser (if name 
                          (make-new-symbol name)
                          (make-new-symbol 'danser))))
    
    (setf (slot-value self 'name) name-of-danser
          (symbol-value name-of-danser) self)
    name-of-danser))


(defmethod print-object ((self danser) stream)
  (format stream
          "<danser ~S>" (name self) )
  (values))



;(assoc :support '((:support 'y) (:rotation 1)))


(defclass DIMENSION ()
   ((name :initarg :name :initform nil :accessor name :type symbol)
    (type :initarg :type :initform nil :accessor type :type symbol)
    (mode :initarg :mode :initform nil :accessor mode :type keyword)
    (values-set :initarg :values-set :initform nil :accessor values-set)
    (datum :initarg :datum :initform nil :accessor datum)
    (free :initarg :free :initform nil :accessor free))
   (:documentation "DIMENSION (LOL class) : Meta class for all dimensions including Laban dimensions.
Slots are :name :type. "))

(defmethod initialize-instance :after ((self dimension) &key
                                         name type mode values-set
                                         datum)
   (when (not name) (setf (slot-value self 'name) (make-new-symbol 'dimension)))
   (when (not type) (setf (slot-value self 'type) :crispy))
   (when (not mode) (setf (slot-value self 'mode) :absolute))
   (when (not values-set) (if (eq :crispy (type self))
                            (setf (slot-value self 'values-set) '(nil 1 2 3 4 5 6 7 8))
                            (setf (slot-value self 'values-set) nil)))
   (when (not datum) (setf (slot-value self 'datum) (car (slot-value self 'values-set))))
   )

(defmethod print-object ((self dimension) stream)
  (format stream
          "<DIMENSION ~S>" (name self) )
  (values))


(defmethod dimension-p ((self dimension))
  t
  )

(defmethod dimension-p ((self t))
  nil
  )
    

#|
(inspect
(make-instance :support :name :support))
|#


(defclass LABAN-DIMENSION (dimension)
   ()
   (:documentation "DIMENSION (LOL class) : Meta class for Laban dimensions.
Slots are :name :body :supports :directions :levels :rotations :amplitudes :flexions :contacts :qualities. ")
   )

(defmethod print-object ((self laban-dimension) stream)
  (format stream
          "<LABAN DIMENSION ~S>" (name self) )
  (values))

(defclass support (laban-dimension)
  ()
  (:default-initargs
    :name :support
    :type :crispy
    :mode :absolute
    :values-set (get-default-values :support)
    :datum (car (get-default-values :support))))

(defclass level (laban-dimension)
  ()
  (:default-initargs
    :name :level
    :type :crispy
    :mode :absolute
    :values-set (get-default-values :level)
    :datum (car (get-default-values :level))))

(defclass direction (laban-dimension)
  ()
  (:default-initargs
    :name :direction
    :type :crispy
    :mode :absolute
    :values-set (get-default-values :direction)
    :datum (car (get-default-values :direction))))

(defclass rotation (laban-dimension)
  ()
  (:default-initargs
    :name :rotation
    :type :crispy
    :mode :absolute
    :values-set (get-default-values :rotation)
    :datum (car (get-default-values :rotation))))

(defclass distance (laban-dimension)
  ()
  (:default-initargs
    :name :distance
    :type :crispy
    :mode :absolute
    :values-set (get-default-values :distance)
    :datum (car (get-default-values :distance))))

(defclass flexion (laban-dimension)
   ()
   (:default-initargs
     :name :flexion
     :type :crispy
     :mode :absolute
     :values-set (get-default-values :flexion)
     :datum (car (get-default-values :flexion))))

(defclass curve (laban-dimension)
   ()
   (:default-initargs
     :name :curve
     :type :crispy
     :mode :absolute
     :values-set (get-default-values :curve)
     :datum (car (get-default-values :curve))))

(defclass contact (laban-dimension)
   ()
   (:default-initargs
     :name :contact
     :type :crispy
     :mode :absolute
     :values-set (get-default-values :contact)
     :datum (car (get-default-values :contact))))

(defclass address (laban-dimension)
   ()
   (:default-initargs
     :name :address
     :type :crispy
     :mode :absolute
     :values-set (get-default-values :address)
     :datum (car (get-default-values :address))))


(defclass inclin (laban-dimension)
   ()
   (:default-initargs
     :name :inclin
     :type :crispy
     :mode :absolute
     :values-set (get-default-values :inclin)
     :datum (car (get-default-values :inclin))))


(defmethod initialize-instance :before ((self laban-dimension) &key)
   (let ((set (get-default-values (type-of self))))
     (setf (slot-value self 'values-set) set
           (slot-value self 'datum) (car set))
     self))


(defmethod initialize-instance :after ((self contact) &key)
  (setf (slot-value self 'values-set) (append (values-set self) (mapcar #'class-name (find-subclasses 'danser))))
  self)


(defmethod initialize-instance :after ((self address) &key)
  (setf (slot-value self 'values-set) (append (values-set self) (mapcar #'class-name (find-subclasses 'danser))))
  self)



#|
(setf b (make-instance 'bodypart))
(dimension-list b)
(dimension b)
(dimension b :dim :support)
(dimension b :dim 'support)
(dimension-value b :dim 'support)
|#




(defclass SITUATION ()
   ((name
     :initarg :name
     :initform 'Situation
     :accessor name
     :type symbol)
    (danser
     :initarg :danser
     :initform 'nil
     :accessor danser
     :type symbol)
    (data
     :initarg :data
     :reader data
     :initform '()
     :accessor data
     :type list)
    (dimension-list
     :initarg :dimension-list
     :initform nil
     :reader dimension-list
     :accessor dimension-list
     :type list)
    (body
     :initarg :body
     :reader body
     :initform '()
     :accessor body
     :type list)
    (color
     :initarg :color
     :initform *black-color* ;*wind-sit-back-color*
     :accessor color
     :type integer)
    (creation-date
     :initarg :creation-date
     :initform 0
     :accessor creation-date
     :type number)
    (modif-date
     :initarg :modif-date
     :initform '()
     :accessor modif-date
     :type list)
    (ancestor
     :initarg :ancestor
     :initform '()
     :accessor ancestor
     :type list)
    )
   (:documentation "SITUATION (LOL class) : General class for situation and body classes.
Slots are :name :body :supports :directions :levels :rotations :amplitudes :flexions :contacts :qualities. ")
   )

(defmethod initialize-instance :after ((self situation) &key
                                         name
                                         danser
                                         creation-date
                                         verbose)
  (let ((name-of-situation (if name 
                             (make-new-symbol (read-from-string name))
                             (make-new-symbol 'situation)))
        )
    (when (danser self)
      (when (color (danser self))
        (setf (slot-value self  'color) (color (danser self)))))
    (setf (symbol-value name-of-situation) self)
    (when (not danser)
      (let ((danser (make-instance 'danser)))
        (setf (slot-value (symbol-value name-of-situation) 'danser) danser)))
    (setf (slot-value (symbol-value name-of-situation) 'name) (string name-of-situation))
    (when (not creation-date)
      (setf (slot-value (symbol-value name-of-situation) 'creation-date)  (get-universal-time)))
    (when verbose
      (format t "Situation ~S created.~%" (name (eval name-of-situation))))
    (values self)))


(defmethod danser ((self symbol))
  (danser (eval self)))

(defmethod name ((self symbol))
  (name (eval self)))

(defmethod situation ((self symbol))
  (situation (eval self)))

(defmethod situation-name ((self situation))
  (name self))

(defmethod body ((self null))
  nil)

#|
(inspect
(make-instance 'situation)
)
|#


(defun situation-p (object)
  "Test if class is a situation."
  (eq 'situation (type-of object)))


(defmethod print-object ((self situation) stream)
  (format stream
          "<SITUATION ~S>" (name self) )
  (values))



(defclass MARKER ()
   ((function :initarg :func :initform nil :accessor func)
    (number :initarg :number :initform nil :accessor number)
    ))


(defmethod markerp ((self marker))
  t)


(defmethod markerp ((self t))
  nil)


(defmethod markerp ((self null))
  nil)


(defclass BODYPART ()
  ((name
    :initarg :name
    :initform nil
    :reader name
    :accessor name
    :type symbol)
   (dimension-list
    :initarg :dimension-list
    :initform nil
    :reader dimension-list
    :accessor dimension-list
    :type list)
   (creation-date
    :initarg :creation-date
    :initform 0
    :accessor creation-date
    :type number)
   (modif-date
    :initarg :modif-date
    :initform '()
    :accessor modif-date
    :type list)
   )
   (:documentation "BODYPART (LOL class) : Metaclass of body subparts (elements) in LOL.
Slots are :name :window :dimension :properties.")
   )

(defmethod initialize-instance :after ((self bodypart) &key)
   (if (name self)
     (setf (slot-value self 'name) (string (make-new-symbol (read-from-string (name self)))))
     (setf (slot-value self 'name) (string (make-new-symbol (class-name (class-of self))))))
   (setf (symbol-value (read-from-string (name self))) self)
   (when (not (dimension-list self))
     (setf (slot-value self 'dimension-list)
           (mapcar #'make-instance *Laban-dimensions*))))


(defmethod print-object ((self bodypart) stream)
  (format stream
          "<~S ~S>" (class-name (class-of self)) (name self))
  (values))


(defmethod BODYPART-p ((self t))
  nil)

(defmethod BODYPART-p ((self BODYPART))
  t)




(defmethod dimension ((self bodypart) &key dim)
   (cond ((not dim)
          (dimension-list self))
         ((symbolp dim)
          (let ((d (find dim (dimension-list self) :key 'name)))
            (if (not d)
              (find (make-keyword dim) (dimension-list self) :key 'name)
              d)))
         (t nil)))


(defmethod dimension-value ((self bodypart) &key dim)
   (cond ((not dim)
          (mapcar #'datum (dimension-list self)))
         ((symbolp dim)
          (let ((d (find dim (dimension-list self) :key 'name)))
            (if (not d)
              (datum (find (make-keyword dim) (dimension-list self) :key 'name))
              (datum d))))
         (t nil)))




(defgeneric subdivise (object)
  (:documentation
   "SUBDIVISE is a LOL generic function.
Give the possible subobjects of <object>."))

(defmethod subdivise ((object symbol))
   (cond ((eq 't object)
          nil)
         ((eq 'body object)
          (subdivise 'bodypart))
         ((class-exist-p object)
          (cond ((member 'UNSUBDIVISIBLE
                      (mapcar #'class-name 
                              (CLASS-DIRECT-SUPERCLASSES (find-class object))))
                 (format *standard-output* "Warning : class ~S can not be subdivised." 
                         object)
                 object)
                (t
                 (mapcar #'class-name (find-subclasses object)))))
         (t
          (lol-error-msg
           (format nil "Error : class ~S does not exist.~%~%Can't subdivise." 
                   object)))))

(defmethod subdivise ((object list))
   (mapcar #'subdivise object))

(defmethod subdivise ((object null))
   nil)

(defmethod subdivise ((object t))
   nil)

#|
(defmethod subdivise ((object unsubdivisible))
   (format *standard-output* "Warning : class ~S can not be subdivised." 
                         object)
   object)
|#

(defmethod subdivise ((object bodypart))
   (setf object (class-name (class-of object)))
   (mapcar #'(lambda (x)
               (make x nil))
           (subdivise object)))

#|
(defmethod subdivise ((object body))
   (elements object))
|#


#|
(subdivise 'arm)
(subdivise (make-instance 'arm))
(subdivise '(arm leg))
(subdivise (mapcar #'make-instance '(arm leg)))
(subdivise 'support)
(subdivise (make-instance 'support))
(subdivise (make-instance 'contact))
(subdivise 'contact)
(subdivise (make 'body nil))
(subdivise 'bodypart)
(subdivise 'body)
(subdivise 'nil)
(subdivise 't)
|#





;;; *********************************************************
;;; ****************** QUANTIFICATION TOOLS *****************
;;; *********************************************************

(defclass NUMERICAL ()
  ((value
    :initarg :value
    :initform nil
    :reader value
    :accessor value
    :type number)
   (frac
    :initarg :frac
    :initform 1
    :reader frac
    :accessor frac
    :type number)
   )
   (:documentation "NUMERICAL (LOL class) : Used to define if an object that inherits this
class is numerical or not.
Slot are :value and :frac.")
   )

(defgeneric numerical-p (object)
  (:documentation
   "Tests if an object is numerical or not."))


(defmethod numerical-p ((object numerical))
  t)

(defmethod numerical-p ((object t))
  nil)

(defmethod fuzzy-p ((object numerical))
  (if (null (value object))
    t nil))

(defclass MODULO (numerical)
   ((modulo
     :initarg :modulo
     :initform 360
     :reader modulo
     :accessor modulo
     :type number)
    )
   (:documentation "MODULO (LOL class) : Used to define if an numerical object that inherits this
class has or not a modulo.
Slots is :modulo.")
   )

(defgeneric modulo-p (object)
  (:documentation
   "Tests if an object has a modulo or not."))


(defmethod modulo-p ((object modulo))
  t)

(defmethod modulo-p ((object t))
  nil)