;; CL code for life coding platform

;; --------------------------------------------conceptual

;; - doubling

;; - (and how differs from) mirroring /and/ symmetry

;; - enframe/frames

;; - isa (within the category of)

;; - overlay

;; - transparency/opacity - and thus to opposition

;; - embedding (spatial relations - exteriority/expulsion/laying open in the world

;; - slots and properties (eg. devices, actors, cast and so on - live process)

;; -> original kodiak.lisp > dom (sub in PAIP), rel, ind, val, and [further] each, dif, when, not, and
;; dom/sub - (sub dog animal) dog is a kind of animal
;; rel - (rel birthday animal date) birthday relation holds between animal and some date
;; ind (ind fido dog) the individual fido is categorised as a dog
;; val (val birthday fido july-1) the birthday of ind fido is july-1
;; and (and A B) bothe A and B are true // leave rest ...

;; from kodiak.lisp :


;;Syntax:
;;  (a category [inst] (rel value)*)

;;Example:
;;  (a person (name (a person-name (first Joe) (last Smith))) (age old))
;;  ==>
;;  (and (ind person-1 Joe) (val name person-1 person-name-1) 
;;       (val age person-1 old) (val first person-name-1 Joe)
;;       (val last person-name-1 Smith))

;;Syntax:
;;   (each category [(isa super*)] (rel constraint)*)
;;
;;  Example:
;;  (each person (isa animal) (name person-name) (age integer))
;;  ==>
;;  (and (dom person animal) (rel name person person-name) 
;;       (rel age person integer))
;;||#

(load "/root/experiment/kodiak2")

(clear-db)

;; copy across alice.lisp

;; here:

;; print options

(query-bind (?x ?y) '(dom ?x ?y)
	    (format t "A ~a is ~a.~%" ?x ?y))

(query-bind (?z ?x ?y) '(rel ?z ?x ?y)
	    (format t "The relation ~a holds between ~a and ~a.~%" ?z ?x ?y))

;; tools

(defun system (command-string)
	   (let ((proc (run-program "/bin/sh" (list "-c" command-string)
				    :wait t :input t :output t :error t)))
	     (prog1 (process-exit-code proc) (process-close proc))))

;; and panel.lisp functions

(defmacro pull (obj place &rest args)
  (multiple-value-bind (vars forms var set access)
                       (get-setf-method place)
    (let ((g (gensym)))
      `(let* ((,g ,obj)
              ,@(mapcar #'list vars forms)
              (,(car var) (delete ,g ,access ,@args)))
         ,set))))

;; process code


(proclaim '(special *procs* *proc*))


(setq *cont* #'identity)

(defmacro =defun (name parms &body body)
  (let ((f (intern (concatenate 'string
				"=" (symbol-name name)))))
    `(progn
       (defmacro ,name ,parms
	 `(,',f *cont* ,,@parms))
       (defun ,f (*cont* ,@parms) ,@body))))

(defmacro =bind (parms expr &body body)
  `(let ((*cont* #'(lambda ,parms ,@body))) ,expr))

(defmacro =values (&rest retvals)
  `(funcall *cont* ,@retvals))

(defmacro =funcall (fn &rest args)
  `(funcall ,fn *cont* ,@args))

(defvar *halt* (gensym))

(defstruct proc pri state wait)

(defvar *default-proc*
  (make-proc :state #'(lambda (x)
			(format t "~%>> ")
			(princ (eval (read)))
			(pick-process))))

(defmacro fork (expr pri)
  `(prog1 ',expr
     (push (make-proc
	    :state #'(lambda (,(gensym))
		       ,expr
		       (pick-process))
	    :pri   ,pri)
	   *procs*)))

(defmacro program (name args &body body)
  `(=defun ,name ,args
	   (setq *procs* nil)
	   ,@body
	   (catch *halt* (loop (pick-process)))))

(defun pick-process ()
  (multiple-value-bind (p val) (most-urgent-process)
    (setq *proc*  p
	  *procs* (delete p *procs*))
    (progn
      (princ (proc-state p))
      (funcall (proc-state p) val))))


;;(loop (pick-process))

(defun most-urgent-process ()
  (let ((proc1 *default-proc*) (max -1) (val1 t))
    (dolist (p *procs*)
      (let ((pri (proc-pri p)))
	(if (> pri max)
	    (let ((val (or (not (proc-wait p))
			   (funcall (proc-wait p)))))
	      (when val
		(setq proc1 p
		      max   pri
		      val1  val))))))
    (values proc1 val1)))

(defun arbitrator (test cont)
  (setf (proc-state *proc*) cont
	(proc-wait *proc*)  test)
  (push *proc* *procs*)
  (pick-process))

(defmacro wait (parm test &body body)
  `(arbitrator #'(lambda () ,test)
	       #'(lambda (,parm) ,@body)))

(defmacro yield (&body body)
  `(arbitrator nil #'(lambda (,(gensym)) ,@body)))

(defun setpri (n) (setf (proc-pri *proc*) n))

(defun halt (&optional val) (throw *halt* val))

(defun kill (&optional obj &rest args)
  (if obj
      (setq *procs* (apply #'delete obj *procs* args))
    (pick-process)))

(defmacro while (test &rest body)
  `(do ()
       ((not ,test))
     ,@body))

(defvar *piksel_board* nil)

(defun test (&rest f) (find f *panel_board* :test #' equal))

(defun state (&rest f) (push f *panel_board*))

(defun unstate (&rest f) (pull f *panel_board*))

;; see fork usw. there

;; media playback



;; also to save lists/structures to disk as:

(defun save-db (filename)
  (with-open-file (out filename
                   :direction :output
                   :if-exists :supersede)
    (with-standard-io-syntax
      (dolist (predicate *primitives*)
	(print (get-dtree predicate) out)))))

(defun load-db (filename)
  (with-open-file (in filename)
    (with-standard-io-syntax
      (dolist (predicate *primitives*)
	(setf (get predicate 'dtree) (read in))))))

;; testing

(add-fact '(dom revelation world))

(add-fact '(dom embedded embedding))

(?- (dom ?y ?z))

(save-db "test.db")

(load-db "test.db")