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