Browse code
initial
Ed L authored on 30/10/2015 08:10:10Showing 1 changed files
| 1 | 1 |
new file mode 100644 |
| ... | ... |
@@ -0,0 +1,109 @@ |
| 1 |
+(load #p"~/quicklisp/setup.lisp") |
|
| 2 |
+(declaim (optimize (speed 0) (safety 3) (debug 3))) |
|
| 3 |
+ |
|
| 4 |
+(ql:quickload :cl-charms) |
|
| 5 |
+(ql:quickload :cells) |
|
| 6 |
+(ql:quickload :alexandria) |
|
| 7 |
+(ql:quickload :anaphora) |
|
| 8 |
+ |
|
| 9 |
+(defpackage :lisp-edit |
|
| 10 |
+ (:use :cl :cl-charms :cells :alexandria :anaphora)) |
|
| 11 |
+(in-package :lisp-edit) |
|
| 12 |
+ |
|
| 13 |
+ |
|
| 14 |
+(defun apply-cursor-action (action) |
|
| 15 |
+ (case action |
|
| 16 |
+ ((:up) (cons 0 -1)) |
|
| 17 |
+ ((:down) (cons 0 1)) |
|
| 18 |
+ ((:left) (cons -1 0)) |
|
| 19 |
+ ((:right) (cons 1 0)))) |
|
| 20 |
+ |
|
| 21 |
+ |
|
| 22 |
+(defun dispatch-char (c) |
|
| 23 |
+ (case c |
|
| 24 |
+ ((nil) nil) |
|
| 25 |
+ ((#\j) :down ) |
|
| 26 |
+ ((#\h) :left ) |
|
| 27 |
+ ((#\k) :up ) |
|
| 28 |
+ ((#\l) :right) |
|
| 29 |
+ ((#\f) :paint) |
|
| 30 |
+ ((#\q #\Q) :quit))) |
|
| 31 |
+ |
|
| 32 |
+(defmodel input-handler () |
|
| 33 |
+ ((input-key :cell :ephemeral :accessor input-key :initform (c-in nil)) |
|
| 34 |
+ (action :cell :ephemeral :accessor action :initform (c? (dispatch-char (^input-key)))))) |
|
| 35 |
+ |
|
| 36 |
+(defmodel cursor () |
|
| 37 |
+ ((action :cell :ephemeral :initarg :action :accessor action :initform (c-in nil)) |
|
| 38 |
+ (delta :accessor cursor-delta :initform |
|
| 39 |
+ (c? (apply-cursor-action (^action)))) |
|
| 40 |
+ (x :accessor cursor-x :initarg :x :initform (c... (0) (car (^cursor-delta)))) |
|
| 41 |
+ (y :accessor cursor-y :initarg :y :initform (c... (0) (cdr (^cursor-delta)))))) |
|
| 42 |
+ |
|
| 43 |
+(defvar *input-handler*) |
|
| 44 |
+(defvar *painter*) |
|
| 45 |
+(defvar *cursor*) |
|
| 46 |
+ |
|
| 47 |
+(defun paint () |
|
| 48 |
+ (with-restored-cursor *standard-window* |
|
| 49 |
+ (write-char-at-cursor *standard-window* |
|
| 50 |
+ (if (char/= #\Space (char-at-cursor *standard-window*)) |
|
| 51 |
+ #\Space |
|
| 52 |
+ #\*)))) |
|
| 53 |
+ |
|
| 54 |
+(defun constrain-pos (elem pos delta window-dimensions) |
|
| 55 |
+ (let* ((accessor (case elem |
|
| 56 |
+ ((:x) #'car) |
|
| 57 |
+ ((:y) #'cdr))) |
|
| 58 |
+ (window-elem (funcall accessor window-dimensions)) |
|
| 59 |
+ (delta-elem (funcall accessor delta)) |
|
| 60 |
+ (pos-elem (funcall accessor pos)) |
|
| 61 |
+ (naive-delta (mod (+ pos-elem delta-elem) |
|
| 62 |
+ window-elem)) |
|
| 63 |
+ (real-delta (- naive-delta pos-elem))) |
|
| 64 |
+ real-delta)) |
|
| 65 |
+ |
|
| 66 |
+ |
|
| 67 |
+(defun main () |
|
| 68 |
+ (cells-reset) |
|
| 69 |
+ (handler-case |
|
| 70 |
+ (with-curses () |
|
| 71 |
+ (disable-echoing) |
|
| 72 |
+ (enable-raw-input :interpret-control-characters t) |
|
| 73 |
+ (enable-non-blocking-mode *standard-window*) |
|
| 74 |
+ |
|
| 75 |
+ (let* ((*input-handler* (make-instance 'input-handler)) |
|
| 76 |
+ (*cursor* (make-instance 'cursor :action (c? (action *input-handler*)))) |
|
| 77 |
+ (screen-dimensions (multiple-value-list (window-dimensions *standard-window*)))) |
|
| 78 |
+ |
|
| 79 |
+ (defobserver action ((self input-handler)) |
|
| 80 |
+ (case new-value |
|
| 81 |
+ ((:paint) (paint)))) |
|
| 82 |
+ |
|
| 83 |
+ |
|
| 84 |
+ (defobserver y ((self cursor)) |
|
| 85 |
+ (with-integrity (:change) |
|
| 86 |
+ (let ((adjusted-n-v (mod new-value |
|
| 87 |
+ (cadr screen-dimensions)))) |
|
| 88 |
+ (if (/= new-value adjusted-n-v) |
|
| 89 |
+ (setf (^cursor-y) (- adjusted-n-v new-value)) |
|
| 90 |
+ (move-cursor *standard-window* |
|
| 91 |
+ (^cursor-x) adjusted-n-v))))) |
|
| 92 |
+ |
|
| 93 |
+ (defobserver x ((self cursor)) |
|
| 94 |
+ (with-integrity (:change) |
|
| 95 |
+ (let ((adjusted-n-v (mod new-value |
|
| 96 |
+ (car screen-dimensions)))) |
|
| 97 |
+ (if (/= new-value adjusted-n-v) |
|
| 98 |
+ (setf (^cursor-x) (- adjusted-n-v new-value)) |
|
| 99 |
+ (move-cursor *standard-window* |
|
| 100 |
+ adjusted-n-v (^cursor-y)))))) |
|
| 101 |
+ |
|
| 102 |
+ (loop :named driver-loop |
|
| 103 |
+ :for c := (get-char *standard-window* :ignore-error t) |
|
| 104 |
+ :do (progn |
|
| 105 |
+ (refresh-window *standard-window*) |
|
| 106 |
+ |
|
| 107 |
+ (setf (input-key *input-handler*) c))))) |
|
| 108 |
+ (sb-sys:interactive-interrupt (c) (declare (ignore c))))) |
|
| 109 |
+ |