(load #p"~/quicklisp/setup.lisp")
(declaim (optimize (speed 0) (safety 3) (debug 3)))

(ql:quickload :cl-charms)
(ql:quickload :cells)
(ql:quickload :alexandria)
(ql:quickload :anaphora)

(defpackage :lisp-edit
  (:use :cl :cl-charms :cells :alexandria :anaphora))
(in-package :lisp-edit)

(defun apply-cursor-action (action)
  (case action
    ((:up)    (cons  0 -1))
    ((:down)  (cons  0  1))
    ((:left)  (cons -1  0))
    ((:right) (cons  1  0))))

(defun dispatch-char (c)
  (case c
    ((nil) nil)
    ((#\j) :down )
    ((#\h) :left )
    ((#\k) :up   )
    ((#\l) :right)
    ((#\f) :paint)
    ((#\q #\Q) :quit)))

(defmodel input-handler ()
          ((input-key :cell :ephemeral :accessor input-key :initform (c-in nil))
           (action :cell :ephemeral :accessor action :initform (c? (dispatch-char (^input-key))))))

(defmodel cursor ()
          ((action :cell :ephemeral :initarg :action :accessor action :initform (c-in nil))
           (current-char :initarg :current-char :accessor current-char :initform (c-in nil))
           (delta :accessor cursor-delta :initform
                  (c? (apply-cursor-action (^action))))
           (x :accessor cursor-x :initarg :x :initform (c... (0) (car (^cursor-delta))))
           (y :accessor cursor-y :initarg :y :initform (c... (0) (cdr (^cursor-delta))))))

(defun map-actions (current-char action)
  (case action
    ((:paint) (case current-char
                ((#\#) #\Space)
                ((#\Space) #\*)
                ((#\*) #\#)))))

(defmodel painter ()
          ((action :cell :ephemeral :initarg :action :accessor action :initform (c-in nil))
           (current-char :initarg :current-char :accessor current-char :initform (c-in nil))
           (output :cell :ephemeral :accessor output :initform (c? (map-actions (^current-char)
                                                                                (^action))))))

(defvar *input-handler*)
(defvar *painter*)
(defvar *cursor*)

(defun paint ()
  (with-restored-cursor *standard-window*
    (write-char-at-cursor *standard-window*
                          (if (char/= #\Space (char-at-cursor *standard-window*))
                            #\Space
                            #\*))))

(defun constrain-pos (elem pos delta window-dimensions)
  (let* ((accessor (case elem
                     ((:x) #'car)
                     ((:y) #'cdr)))
         (window-elem (funcall accessor window-dimensions))
         (delta-elem (funcall accessor delta))
         (pos-elem (funcall accessor pos))
         (naive-delta (mod (+ pos-elem delta-elem)
                           window-elem))
         (real-delta (- naive-delta pos-elem)))
    real-delta))


(defun main ()
  (cells-reset)
  (handler-case
    (with-curses ()
      (disable-echoing)
      (enable-raw-input :interpret-control-characters t)
      (enable-non-blocking-mode *standard-window*)

      (setf *input-handler* (make-instance 'input-handler) 
            *cursor* (make-instance 'cursor :action (c? (action *input-handler*)))
            *painter* (make-instance 'painter
                                     :action (c? (action *input-handler*))
                                     :current-char (c? (current-char *cursor*))))

      (let* ((screen-dimensions (multiple-value-bind (x y) (window-dimensions *standard-window*)
                                  (cons x y))))
        (labels
          ((set-current-char (cursor)
             (with-restored-cursor *standard-window*
               (setf (current-char cursor) (char-at-cursor *standard-window*))))
           (mvc (x y)
             (move-cursor *standard-window* x y)
             (set-current-char *cursor*))
           (constrain-coordinate (side coord)
             (mod coord (funcall
                          (ecase side
                            ((:x) #'car)
                            ((:y) #'cdr))
                          screen-dimensions))))

          (defobserver output ((self painter))
                       (with-restored-cursor *standard-window*
                         (write-char-at-cursor *standard-window* new-value))
                       (with-integrity (:change)
                         (set-current-char *cursor*)))

          (defobserver y ((self cursor))
                       (with-integrity (:change)
                         (let ((adjusted-n-v (constrain-coordinate :y new-value)))
                           (if (/= new-value adjusted-n-v)
                             (setf (^cursor-y) (- adjusted-n-v new-value))
                             (mvc (^cursor-x) adjusted-n-v)))))

          (defobserver x ((self cursor))
                       (with-integrity (:change)
                         (let ((adjusted-n-v (constrain-coordinate :x new-value)))
                           (if (/= new-value adjusted-n-v)
                             (setf (^cursor-x) (- adjusted-n-v new-value))
                             (mvc adjusted-n-v (^cursor-y))))))

          (mvc 0 0)
          (loop :named driver-loop
                :for c := (get-char *standard-window* :ignore-error t)
                :do (progn
                      (refresh-window *standard-window*)
                      (setf (input-key *input-handler*) c))))))

    (sb-sys:interactive-interrupt (c) (declare (ignore c)))))