console.lisp

   1 ;;LIFP module for input/output\r
   2 ;;\r
   3 ;;This file is a part of Lisp Interactive Fiction Project\r
   4 ;;\r
   5 ;;See license.txt for licensing information\r
   6 \r
   7 (in-package :cl-user)\r
   8 (defpackage :if-console\r
   9   (:use :common-lisp :ltk :com.gigamonkeys.pathnames)\r
  10   (:export :terminal-in :terminal-out\r
  11    :run-console :console-running-p :textwidth :offset :style\r
  12    :*text* :get-input :ltk-after :*repl-mode* :*hard-quit* :quit-lisp\r
  13    :close-console :load-module :print-message))\r
  14 \r
  15 (in-package :if-console)\r
  16 \r
  17 (defparameter *repl-mode* nil)\r
  18 (defparameter *console-on* nil)\r
  19 (defparameter *text* nil)\r
  20 (defparameter *inp* nil)\r
  21 (defparameter *current-path* nil)\r
  22 (defparameter *hard-quit* nil)\r
  23 \r
  24 (defun quit-lisp ()\r
  25   #+clisp (ext:quit)\r
  26   #+sbcl (quit))\r
  27 \r
  28 (defclass terminal-out (gray:fundamental-character-output-stream)\r
  29   ((textwidth :initarg textwidth :initform 72 :accessor textwidth)\r
  30    (offset :initarg offset :initform 0 :accessor offset)\r
  31    (style :initarg style :initform 0 :accessor style)))\r
  32 \r
  33 (defclass terminal-in (gray:fundamental-character-input-stream) \r
  34   ((buffer :initform "" :accessor buffer)))\r
  35 \r
  36 (defmethod gray:stream-write-char ((s terminal-out) char)\r
  37   (unless (console-running-p) (error "No console is running"))\r
  38   (if *repl-mode* (princ char)\r
  39       (append-text (first *console-on*) \r
  40                    (make-string 1 :initial-element char))))\r
  41 \r
  42 (defmethod gray:stream-line-column ((s terminal-out))\r
  43   (offset s))\r
  44 \r
  45 (defmethod gray:stream-write-char-sequence ((s terminal-out) str\r
  46                                             &optional start end)\r
  47   (unless (console-running-p) (error "No console is running"))\r
  48   (let ((toprint (subseq str (if start start 0) (if end end nil))))\r
  49     (if *repl-mode* (princ toprint)\r
  50         (progn\r
  51           (append-text (first *console-on*) toprint)\r
  52           (see (first *console-on*) "insert")))))\r
  53 \r
  54 (defmethod gray:stream-read-char ((s terminal-in))\r
  55   (if *repl-mode* (read-char *standard-input*)\r
  56       (let* ((l (length (buffer s)))\r
  57              (c (when (> l 0) (elt (buffer s) 0)))\r
  58              (rest (when (> l 0) (subseq (buffer s) 1))))\r
  59         (if c (progn (setf (buffer s) rest) c) :eof))))\r
  60 \r
  61 (defmethod gray:stream-unread-char ((s terminal-in) c)\r
  62   (let ((new (make-string (1+ (length (buffer s))))))\r
  63     (setf (elt new 0) c)\r
  64     (setf (subseq new 1) (buffer s))\r
  65     (setf (buffer s) new)))\r
  66     \r
  67 (defmethod gray:stream-read-line ((s terminal-in))\r
  68   (if *repl-mode* (read-line *standard-input*)\r
  69       (let ((what (buffer s)))\r
  70         (setf (buffer s) "")\r
  71         what)))\r
  72 \r
  73 (defun center-text (text)\r
  74   (see text "insert"))\r
  75   ;(format-wish "~A yview 10 units" (widget-path text)))\r
  76 \r
  77 (defun console-running-p () (or *repl-mode* *console-on*))\r
  78 \r
  79 (defun get-input (instream outstream)\r
  80   (unless *repl-mode* \r
  81     (center-text *text*)\r
  82     (let ((inp (make-instance 'entry))\r
  83           (flag nil))\r
  84       (insert-object *text* inp)\r
  85       (configure inp :background "light gray" :relief "flat" :width 100)\r
  86       (focus inp) (setf *inp* inp)\r
  87       (configure *text* :state "disabled")\r
  88       (bind inp "<KeyPress-Return>" \r
  89             (lambda (evt)\r
  90               (declare (ignore evt))\r
  91               (setf (buffer instream) (text inp))\r
  92               (setf flag t)))\r
  93       (loop do (process-events) until flag)\r
  94       (configure *text* :state "normal")\r
  95       (let ((command (text inp)))\r
  96         (destroy inp)\r
  97         (append-text *text* command)\r
  98         (terpri outstream)\r
  99         (setf (offset outstream) 0)\r
 100         command))))\r
 101 \r
 102 (defun pick-file ()\r
 103   (let* ((flag nil) \r
 104          (dialog (make-instance 'toplevel))\r
 105          (ent (make-instance 'entry :master dialog :width 80))\r
 106          (but-ok (make-instance 'button :master dialog\r
 107                                 :text "OK"\r
 108                                 :command (lambda () (setf flag t))))\r
 109          (but-cancel (make-instance 'button :master dialog\r
 110                                     :text "Cancel"\r
 111                                     :command (lambda ()\r
 112                                                (destroy dialog)\r
 113                                                (return-from pick-file\r
 114                                                  (values nil nil))))))\r
 115     (pack ent :expand t :fill :x)\r
 116     (pack but-ok :side :left :expand t :fill :x)\r
 117     (pack but-cancel :side :left :expand t :fill :x)\r
 118     (wm-title dialog "Choose a file to load")\r
 119     (on-close dialog (lambda ()\r
 120                        (destroy dialog)\r
 121                        (return-from pick-file\r
 122                          (values nil nil))))\r
 123     (force-focus dialog)\r
 124     (focus ent)\r
 125     (loop do (process-events) until flag)\r
 126     (destroy dialog)\r
 127     (let* ((file (pathname (text ent)))\r
 128            (dir nil))\r
 129       (unless (file-exists-p file)\r
 130         (append-text *text* "No such file!\r
 131 ")\r
 132         (return-from pick-file (values nil nil)))\r
 133       (setf dir (make-pathname\r
 134                  :directory (pathname-directory file)\r
 135                  :name nil\r
 136                  :type nil\r
 137                  :defaults file))\r
 138       (values file dir))))\r
 139 \r
 140 \r
 141 (defun load-module (startup lib-loader)\r
 142   "Loads IF module into the interpreter"\r
 143   (multiple-value-bind (file dir) (pick-file)\r
 144     (unless file (append-text *text* "Failed to load module.\r
 145 "))\r
 146     (funcall lib-loader file dir)\r
 147     (funcall startup)))\r
 148 \r
 149 (defun run-console (startup lib-loader &key (interactive nil))\r
 150   (if *repl-mode* (progn (funcall startup) \r
 151                          (return-from run-console t))\r
 152   (with-ltk ()\r
 153       (let* ((txt (make-instance 'text))\r
 154              (menu (make-menubar))\r
 155              (m-file (make-menu menu "File"))\r
 156              (m-file-load (make-menubutton m-file "Load Module" \r
 157                                 (lambda () (load-module startup lib-loader))))\r
 158              (m-file-quit (make-menubutton m-file "Quit" \r
 159                                            (lambda () (destroy *tk*))))\r
 160              )\r
 161         (declare (ignore m-file-load m-file-quit))\r
 162         (setf *text* txt)\r
 163         (wm-title *tk* "LIFP - Lisp Interactive Fiction Project")\r
 164         (pack txt :fill :both :expand :both)\r
 165         ;;(pack status :side :left :expand t :fill :x) \r
 166         (setf (text txt) "")\r
 167         (configure txt :font "courier") \r
 168         (setf *console-on* (list txt))\r
 169         (force-focus *tk*)\r
 170         (unless interactive (funcall startup)))))\r
 171   (setf *console-on* nil))\r
 172   \r
 173 (defun ltk-after (time fun)\r
 174   (if *repl-mode* (funcall fun)\r
 175       (ltk:after time fun)))\r
 176 \r
 177 (defun close-console ()\r
 178   (unless *repl-mode*\r
 179     (center-text *text*)\r
 180     (let ((quit-button (make-instance \r
 181                         'button\r
 182                         :text "Quit"\r
 183                         :command (lambda () (destroy *tk*)))))\r
 184       (insert-object *text* quit-button)\r
 185       (focus quit-button))))\r
 186     \r
 187                                 \r
 188 (defun print-message (string &rest args)\r
 189   (if *repl-mode* (progn (apply #'format t string args) \r
 190                          (terpri *standard-output*))\r
 191       (progn (configure *text* :state "normal")\r
 192              (append-text *text* (apply #'format nil string args))\r
 193              (append-text *text* "\r
 194 "))))