1 ;;LIFP module for input/output
\r
3 ;;This file is a part of Lisp Interactive Fiction Project
\r
5 ;;See license.txt for licensing information
\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
15 (in-package :if-console)
\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
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
33 (defclass terminal-in (gray:fundamental-character-input-stream)
\r
34 ((buffer :initform "" :accessor buffer)))
\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
42 (defmethod gray:stream-line-column ((s terminal-out))
\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
51 (append-text (first *console-on*) toprint)
\r
52 (see (first *console-on*) "insert")))))
\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
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
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
73 (defun center-text (text)
\r
74 (see text "insert"))
\r
75 ;(format-wish "~A yview 10 units" (widget-path text)))
\r
77 (defun console-running-p () (or *repl-mode* *console-on*))
\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
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
90 (declare (ignore evt))
\r
91 (setf (buffer instream) (text inp))
\r
93 (loop do (process-events) until flag)
\r
94 (configure *text* :state "normal")
\r
95 (let ((command (text inp)))
\r
97 (append-text *text* command)
\r
99 (setf (offset outstream) 0)
\r
102 (defun pick-file ()
\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
108 :command (lambda () (setf flag t))))
\r
109 (but-cancel (make-instance 'button :master dialog
\r
111 :command (lambda ()
\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
121 (return-from pick-file
\r
122 (values nil nil))))
\r
123 (force-focus dialog)
\r
125 (loop do (process-events) until flag)
\r
127 (let* ((file (pathname (text ent)))
\r
129 (unless (file-exists-p file)
\r
130 (append-text *text* "No such file!
\r
132 (return-from pick-file (values nil nil)))
\r
133 (setf dir (make-pathname
\r
134 :directory (pathname-directory file)
\r
138 (values file dir))))
\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
146 (funcall lib-loader file dir)
\r
147 (funcall startup)))
\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
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
161 (declare (ignore m-file-load m-file-quit))
\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
170 (unless interactive (funcall startup)))))
\r
171 (setf *console-on* nil))
\r
173 (defun ltk-after (time fun)
\r
174 (if *repl-mode* (funcall fun)
\r
175 (ltk:after time fun)))
\r
177 (defun close-console ()
\r
178 (unless *repl-mode*
\r
179 (center-text *text*)
\r
180 (let ((quit-button (make-instance
\r
183 :command (lambda () (destroy *tk*)))))
\r
184 (insert-object *text* quit-button)
\r
185 (focus quit-button))))
\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