
(defpackage :snek
  (:use :common-lisp))



; MACROS


(defmacro insert-vert (v into snk)
  (declare (ignore into))
  (with-gensyms (cname vname)
    `(let ((,vname ,v)
           (,cname (snek-num-verts ,snk)))
     (setf (aref (snek-verts ,snk) ,cname 0) (coerce (first ,vname) 'float))
     (setf (aref (snek-verts ,snk) ,cname 1) (coerce (second ,vname) 'float))
     (- (incf (snek-num-verts ,snk)) 1))))


(defmacro get-vert (v from snk)
  (declare (ignore from))
  (with-gensyms (vname)
    `(let ((,vname ,v))
      (list (aref (snek-verts ,snk) ,vname 0)
            (aref (snek-verts ,snk) ,vname 1)))))


(defmacro get-verts (vv from snk)
  (declare (ignore from))
  (with-gensyms (vname v)
    `(let ((,vname ,vv))
       (loop for ,v in ,vname collect
         (list (aref (snek-verts ,snk) ,v 0)
               (aref (snek-verts ,snk) ,v 1))))))


(defmacro get-edge (e from snk)
  (declare (ignore from))
  (with-gensyms (ename)
    `(let ((,ename ,e))
      (list (aref (snek-edges, snk) ,ename 0)
            (aref (snek-edges ,snk) ,ename 1)))))


(defmacro insert-edge (e into snk)
  (declare (ignore into))
  (with-gensyms (ename edges num)
    `(let ((,ename ,e)
           (,edges (snek-edges ,snk))
           (,num (snek-num-edges ,snk)))
       (cond
         ((-binary-edge-search ,edges ,ename ,num)
          nil)
         ((eql (first ,ename) (second ,ename))
          nil)
         (t
           (setf (snek-num-edges ,snk) (+ 2 ,num))
           (-find-insert-edge ,edges ,num ,ename)
           (sort
             (-find-insert-edge ,edges (1+ ,num) (reverse ,ename))
             #'<))))))


(defmacro remove-edge (e from snk)
  (declare (ignore from))
  (with-gensyms (ename lname edges num)
    `(let ((,ename ,e)
           (,edges (snek-edges ,snk))
           (,num (snek-num-edges ,snk)))

       (setf (snek-num-edges ,snk) (- ,num (loop for ,lname in
         (list
           (-find-remove-edge ,edges ,num ,ename)
           (-find-remove-edge ,edges (1- ,num) (reverse ,ename)))
         sum ,lname)))
       (- ,num (snek-num-edges ,snk)))))


(defmacro get-one-ring (of v from snk)
  (declare (ignore from) (ignore of))
  (with-gensyms (vname)
    `(let ((,vname ,v))
       (-one-ring (snek-edges ,snk) ,vname (snek-num-edges ,snk)))))


(defmacro with-snek ((snk) &body body)
  `(do-alts
     (remove-if-not
       #'alt-p
       (flatten (list ,@body))) ,snk))


(defmacro with-snek-print ((snk) &body body)
  (declare (ignore snk))
  `(print
     (remove-if-not
       #'alt-p
       (flatten (list ,@body)))))


(defmacro with-rnd-edge ((snk i) &body body)
  `(if (> (snek-num-edges ,snk) 0)
    (let ((,i (l-get-as-list
                   (snek-edges ,snk)
                   (random (snek-num-edges ,snk)))))
        (list ,@body))
    nil))


(defmacro with-rnd-vert ((snk i) &body body)
  `(let ((,i (random (snek-num-verts ,snk))))
    (list ,@body)))


(defun -get-force-alterations (u v f)
  (list
    (move-vert v f)
    (move-vert u (lscale f -1.0))))

(defmacro force (snk v1 v2 r)
  (with-gensyms (vname v1name v2name a b aname rname)
    `(let ((,v1name ,v1)
           (,v2name ,v2)
           (,vname (snek-verts ,snk))
           (,rname ,r))
        (-get-force-alterations
          ,v1 ,v2
          (lscale
            (lnsub
              (l-get-as-list ,vname ,v1name)
              (l-get-as-list ,vname ,v2name))
            ,rname)))))


(defmacro with-rnd-vert-value ((snk i) &body body)
  `(let ((,i (l-rand-get (snek-verts ,snk))))
    (list ,@body)))


(defmacro with-all-verts ((snk i) &body body)
  `(loop for ,i from 0 below (snek-num-verts ,snk)
     collect (list ,@body)))



(defmacro with-all-edges ((snk i) &body body)
  (with-gensyms (kname)
    `(loop
        with ,i
        for ,kname from 0 below (snek-num-edges ,snk)
        do
          (setf ,i (l-get-as-list (snek-edges ,snk) ,kname))
        if (< (first ,i) (second ,i))
        collect (list ,@body))))


(defmacro with-prob (p &body body)
  (with-gensyms (pname)
    `(let ((,pname ,p))
       (if (< (random 1.0) ,p)
         (list ,@body)))))



; SNEK

(defstruct snek
  (edges nil :read-only nil)
  (verts nil :read-only nil)
  (num-edges 0 :type integer :read-only nil)
  (num-verts 0 :type integer :read-only nil)
  (max-num 100000 :type integer :read-only t))


(defun snek* (&optional (max-num 100000))
  (make-snek
    :edges (make-int-array max-num)
    :verts (make-float-array max-num)
    :max-num max-num))


(defun -one-ring (edges v num)
  (loop for i from 0 below num
    if (eql v (aref edges i 0))
    collect (l-get-as-list edges i)))


(defun -edge-compare (a b c d)
  (or
    (and (>= a b) (>= c d))
    (> a b)))


(defun -binary-edge-insert-search (arr target num)
  (let ((left 0)
        (right (1- num)))
    (do () ((< right left) left)
      (let ((mid (floor (+ left right) 2)))
        (cond
          ((not (-edge-compare
                  (first target)
                  (aref arr mid 0)
                  (second target)
                  (aref arr mid 1)))
            (setf right (1- mid)))
          (t
            (setf left (1+ mid))))))))


;TODO: is this tail recursive?
(defun -binary-edge-search (arr target num &key (left 0) (right nil))
  (destructuring-bind (a c) target
    (if (eql right nil)
      (setf right (1- num)))
    (let ((mid (floor (+ left right) 2)))
        (cond
          ((< right left) nil)
          ((and
             (eql a (aref arr mid 0))
             (eql c (aref arr mid 1)))
            mid)
          ((not (-edge-compare a (aref arr mid 0) c (aref arr mid 1)))
            (-binary-edge-search arr target num :left left :right (1- mid)))
          (t (-binary-edge-search arr target num :left (1+ mid) :right right))))))


(defun -insert-edge (edges edge pos num)
  (loop for i from 0 below (- num pos) do
    (let ((left (- num (1+ i)))
          (right (- num i)))
      (setf (aref edges right 0) (aref edges left 0))
      (setf (aref edges right 1) (aref edges left 1))))
    (setf (aref edges pos 0) (first edge))
    (setf (aref edges pos 1) (second edge)))


(defun -find-insert-edge (edges num e)
  (-insert-edge
    edges
    e
    (-binary-edge-insert-search edges e num)
    num)
  e)


(defun -remove-edge (edges pos num)
  (loop for i from pos to (2- num) do
    (setf (aref edges i 0) (aref edges (1+ i) 0))
    (setf (aref edges i 1) (aref edges (1+ i) 1)))
  (l-set-from-list edges (1- num) (list 0 0)))


(defun -find-remove-edge (edges num e)
  (let ((p (-binary-edge-search edges e num)))
    (if p
      (progn
       (-remove-edge edges p num) 1)
      0)))



; ALTERATIONS


; MOVE VERT

(defstruct (move-vert-alt
    (:constructor move-vert (v xy &key (rel t))))
  (rel t :type boolean :read-only t)
  (xy nil :type list :read-only t)
  (v -1 :type integer :read-only t))


(defun do-move-vert-alt (a snk)
  (let ((verts (snek-verts snk)))
    (with-struct (move-vert-alt- v xy rel) a
      (if rel
        (l-set-from-list
          verts v
          (ladd
            (l-get-as-list verts v)
            xy))
        (l-set-from-list verts v xy)))))



; APPEND EDGE

(defstruct (append-edge-alt
    (:constructor append-edge (v xy &key (rel t))))
  (xy nil :type list :read-only t)
  (v -1 :type integer :read-only t)
  (rel t :type boolean :read-only t))


(defun do-append-edge-alt (a snk)
  (with-struct (append-edge-alt- v xy rel) a
    (cond
      (rel
        (insert-vert (ladd (get-vert v from snk) xy) into snk))
      (t
        (insert-vert xy into snk)))

      (insert-edge
        (list
          v
          (1- (snek-num-verts snk)))
        into snk)))


; JOIN VERTS

(defstruct (join-verts-alt
    (:constructor join-verts (v1 v2)))
  (v1 -1 :type integer :read-only t)
  (v2 -1 :type integer :read-only t))


(defun do-join-verts-alt (a snk)
  (with-struct (join-verts-alt- v1 v2) a
    (insert-edge (list v1 v2) into snk)))


; SPLIT EDGE

(defstruct (split-edge-alt
    (:constructor split-edge (e)))
  (e nil :type list :read-only t))


(defun do-split-edge-alt (a snk)
  (with-struct (split-edge-alt- e) a
    (let ((res (remove-edge e from snk))
          (verts (snek-verts snk)))
      (destructuring-bind (a b) e
        (if (> res 1)
          (let ((c (insert-vert
                      (lmid (l-get-as-list verts a)
                            (l-get-as-list verts b))
                      into snk)))
            (insert-edge (list a c) into snk)
            (insert-edge (list c b) into snk)))))))


; ALTERATION UTILS

(defun do-alt (a snk)
  (cond
    ((append-edge-alt-p a) (do-append-edge-alt a snk))
    ((move-vert-alt-p a) (do-move-vert-alt a snk))
    ((join-verts-alt-p a) (do-join-verts-alt a snk))
    ((split-edge-alt-p a) (do-split-edge-alt a snk))))


(defun do-alts (alts snk)
  (dolist (a alts) (do-alt a snk)))


(defun alt-p (a)
  (cond
    ((append-edge-alt-p a) t)
    ((move-vert-alt-p a) t)
    ((join-verts-alt-p a) t)
    ((split-edge-alt-p a) t)
    (t nil)))



; OTHER UTILS

(defun edge-length (snk e)
  (with-struct (snek- verts) snk
    (apply #'ldst (mapcar (lambda (v) (l-get-as-list verts v)) e))))


(defun snek-init-circle (snk num rad &key (x 0.0) (y 0.0))
  (let ((verts (loop for i from 0 below num collect
    (insert-vert
      (ladd
        (list x y)
        (lscale (cos-sin (/ (* i PI 2.0) num)) rad)) into snk))))

    (loop for i from 0 below num do
      (insert-edge (list (nth i verts) (nth (mod (1+ i) num) verts))
                    into snk))))

(defun snek-init-line (snk num a b)
  (let ((verts (loop for i from 0 below num collect
    (insert-vert (l-on-line i num a b) into snk))))

    (loop for i from 0 below num do
      (insert-edge (list (nth i verts) (nth (mod (1+ i) num) verts))
                    into snk))))


(defun show-snek-edges (snk)
  (let ((edges (snek-edges snk)))
    (loop for i from 0 below (snek-num-edges snk) do
      (print (aref edges i 0))
      (prin1 (aref edges i 1)))))


(defun show-snek-verts (snk)
  (let ((verts (snek-verts snk)))
    (loop for i from 0 below (snek-num-verts snk) do
      (print (aref verts i 0))
      (prin1 (aref verts i 1)))))

