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 :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
16 (in-package :if-console)
\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
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
35 (defclass terminal-in (gray:fundamental-character-input-stream)
\r
36 ((buffer :initform "" :accessor buffer)))
\r
38 (defmethod gray:stream-write-char ((s terminal-out) char)
\r
39 (unless (console-running-p) (error "No console is running"))
\r
41 (if *repl-mode* (princ char)
\r
42 (append-text (first *console-on*)
\r
43 (make-string 1 :initial-element char)))))
\r
45 (defmethod gray:stream-line-column ((s terminal-out))
\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
52 (let ((toprint (subseq str (if start start 0) (if end end nil))))
\r
53 (if *repl-mode* (princ toprint)
\r
55 (append-text (first *console-on*) toprint)
\r
56 (see (first *console-on*) "insert"))))))
\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
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
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
77 (defun center-text (text)
\r
78 (see text "insert"))
\r
79 ;(format-wish "~A yview 10 units" (widget-path text)))
\r
81 (defun console-running-p () (or *repl-mode* *console-on*))
\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
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
94 (declare (ignore evt))
\r
95 (setf (buffer instream) (text inp))
\r
97 (loop do (process-events) until flag)
\r
98 (configure *text* :state "normal")
\r
99 (let ((command (text inp)))
\r
101 (append-text *text* command)
\r
103 (setf (offset outstream) 0)
\r
106 (defun pick-file ()
\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
112 :command (lambda () (setf flag t))))
\r
113 (but-cancel (make-instance 'button :master dialog
\r
115 :command (lambda ()
\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
125 (return-from pick-file
\r
126 (values nil nil))))
\r
127 (force-focus dialog)
\r
129 (loop do (process-events) until flag)
\r
131 (let* ((file (pathname (text ent)))
\r
133 (unless (file-exists-p file)
\r
134 (append-text *text* "No such file!
\r
136 (return-from pick-file (values nil nil)))
\r
137 (setf dir (make-pathname
\r
138 :directory (pathname-directory file)
\r
142 (values file dir))))
\r
145 (defun load-module (startup lib-loader)
\r
146 "Loads IF module into the interpreter"
\r
147 (multiple-value-bind (file dir) (pick-file)
\r
148 (unless file (append-text *text* (format nil "Failed to load module.~%"))
\r
149 (return-from load-module nil))
\r
150 (funcall lib-loader file dir)
\r
151 (funcall startup)))
\r
153 (defun run-console (startup lib-loader &key (interactive nil))
\r
154 (if *repl-mode* (progn (funcall startup)
\r
155 (return-from run-console t))
\r
156 (with-ltk (:debug :develop :handle-warnings nil)
\r
157 (let* ((txt (make-instance 'text))
\r
158 (menu (make-menubar))
\r
159 (m-file (make-menu menu "File"))
\r
160 (m-file-load (make-menubutton m-file "Load Module"
\r
161 (lambda () (load-module startup lib-loader))))
\r
162 (m-file-quit (make-menubutton m-file "Quit"
\r
163 (lambda () (destroy *tk*))))
\r
165 (declare (ignore m-file-load m-file-quit))
\r
167 (wm-title *tk* "LIFP - Lisp Interactive Fiction Project")
\r
168 (pack txt :fill :both :expand :both)
\r
169 ;;(pack status :side :left :expand t :fill :x)
\r
170 (setf (text txt) "")
\r
171 (configure txt :font "courier")
\r
172 (setf *console-on* (list txt))
\r
174 (unless interactive (funcall startup)))))
\r
175 (setf *console-on* nil))
\r
177 (defun ltk-after (time fun)
\r
178 (if *repl-mode* (funcall fun)
\r
179 (ltk:after time fun)))
\r
181 (defun close-console ()
\r
182 (unless *repl-mode*
\r
183 (center-text *text*)
\r
184 (let ((quit-button (make-instance
\r
187 :command (lambda () (destroy *tk*)))))
\r
188 (insert-object *text* quit-button)
\r
189 (focus quit-button))))
\r
192 (defun print-message (string &rest args)
\r
193 (if *repl-mode* (progn (apply #'format t string args)
\r
194 (terpri *standard-output*))
\r
195 (progn (configure *text* :state "normal")
\r
196 (append-text *text* (apply #'format nil string args))
\r
197 (append-text *text* "
\r