;;LIFP module for input/output
;;
;;This file is a part of Lisp Interactive Fiction Project
;;
;;See license.txt for licensing information

(in-package :cl-user)
(defpackage :if-console
  (:use :common-lisp :ltk :cl-fad)
  (:export :terminal-in :terminal-out
   :run-console :console-running-p :textwidth :offset :style
   :*text* :get-input :ltk-after :*repl-mode* :*no-output*
   :*hard-quit* :quit-lisp
   :close-console :load-module :print-message))

(in-package :if-console)

(defparameter *repl-mode* nil)
(defparameter *no-output* nil)
(defparameter *console-on* nil)
(defparameter *text* nil)
(defparameter *inp* nil)
(defparameter *current-path* nil)
(defparameter *hard-quit* nil)

(defun quit-lisp ()
  #+clisp (ext:quit)
  #+sbcl (quit))

(defclass terminal-out (gray:fundamental-character-output-stream)
  ((textwidth :initarg textwidth :initform 72 :accessor textwidth)
   (offset :initarg offset :initform 0 :accessor offset)
   (style :initarg style :initform 0 :accessor style)))

(defclass terminal-in (gray:fundamental-character-input-stream) 
  ((buffer :initform "" :accessor buffer)))

(defmethod gray:stream-write-char ((s terminal-out) char)
  (unless (console-running-p) (error "No console is running"))
  (unless *no-output*
  (if *repl-mode* (princ char)
      (append-text (first *console-on*) 
		   (make-string 1 :initial-element char)))))

(defmethod gray:stream-line-column ((s terminal-out))
  (offset s))

(defmethod gray:stream-write-char-sequence ((s terminal-out) str
					    &optional start end)
  (unless (console-running-p) (error "No console is running"))
  (unless *no-output*
  (let ((toprint (subseq str (if start start 0) (if end end nil))))
    (if *repl-mode* (princ toprint)
	(progn
	  (append-text (first *console-on*) toprint)
	  (see (first *console-on*) "insert"))))))

(defmethod gray:stream-read-char ((s terminal-in))
  (if *repl-mode* (read-char *standard-input*)
      (let* ((l (length (buffer s)))
             (c (when (> l 0) (elt (buffer s) 0)))
             (rest (when (> l 0) (subseq (buffer s) 1))))
        (if c (progn (setf (buffer s) rest) c) :eof))))

(defmethod gray:stream-unread-char ((s terminal-in) c)
  (let ((new (make-string (1+ (length (buffer s))))))
    (setf (elt new 0) c)
    (setf (subseq new 1) (buffer s))
    (setf (buffer s) new)))
    
(defmethod gray:stream-read-line ((s terminal-in))
  (if *repl-mode* (read-line *standard-input*)
      (let ((what (buffer s)))
        (setf (buffer s) "")
        what)))

(defun center-text (text)
  (see text "insert"))
  ;(format-wish "~A yview 10 units" (widget-path text)))

(defun console-running-p () (or *repl-mode* *console-on*))

(defun get-input (instream outstream)
  (unless *repl-mode* 
    (center-text *text*)
    (let ((inp (make-instance 'entry))
          (flag nil))
      (insert-object *text* inp)
      (configure inp :background "light gray" :relief "flat" :width 100)
      (focus inp) (setf *inp* inp)
      (configure *text* :state "disabled")
      (bind inp "<KeyPress-Return>" 
            (lambda (evt)
              (declare (ignore evt))
              (setf (buffer instream) (text inp))
              (setf flag t)))
      (loop do (process-events) until flag)
      (configure *text* :state "normal")
      (let ((command (text inp)))
        (destroy inp)
        (append-text *text* command)
        (terpri outstream)
        (setf (offset outstream) 0)
	command))))

(defun pick-file ()
  (let* ((flag nil) 
	 (dialog (make-instance 'toplevel))
	 (ent (make-instance 'entry :master dialog :width 80))
	 (but-ok (make-instance 'button :master dialog
				:text "OK"
				:command (lambda () (setf flag t))))
	 (but-cancel (make-instance 'button :master dialog
				    :text "Cancel"
				    :command (lambda ()
					       (destroy dialog)
					       (return-from pick-file
						 (values nil nil))))))
    (pack ent :expand t :fill :x)
    (pack but-ok :side :left :expand t :fill :x)
    (pack but-cancel :side :left :expand t :fill :x)
    (wm-title dialog "Choose a file to load")
    (on-close dialog (lambda ()
		       (destroy dialog)
		       (return-from pick-file
			 (values nil nil))))
    (force-focus dialog)
    (focus ent)
    (loop do (process-events) until flag)
    (destroy dialog)
    (let* ((file (pathname (text ent)))
	   (dir nil))
      (unless (file-exists-p file)
	(append-text *text* "No such file!
")
	(return-from pick-file (values nil nil)))
      (setf dir (make-pathname
		 :directory (pathname-directory file)
		 :name nil
		 :type nil
		 :defaults file))
      (values file dir))))

(defun splice-filename (file)
  "Returns file itself and its directory as the second value"
  (values file (make-pathname
		 :directory (pathname-directory file)
		 :name nil
		 :type nil
		 :defaults file)))

(defun load-module (startup lib-loader)
  "Loads IF module into the interpreter"
  (multiple-value-bind (file dir) 
      (splice-filename (get-open-file :filetypes '(("Loadable files"
                                                    "*.fas *.lisp")
                                                   ("Compiled story files"
                                                    "*.fas")
                                                   ("Plain story files"
                                                    "*.lisp")
                                                   ("All files" "*"))
                                      :title "Load story file"))
      ;;(pick-file) <- was used before
    (unless file (append-text *text* (format nil "Failed to load module.~%"))
            (return-from load-module nil))
    (funcall lib-loader file dir)
    (funcall startup)))

(defun run-console (startup lib-loader &key (interactive nil))
  (if *repl-mode* (progn (funcall startup) 
			 (return-from run-console t))
  (with-ltk (:debug :develop :handle-warnings nil)
      (let* ((txt (make-instance 'text))
	     (menu (make-menubar))
	     (m-file (make-menu menu "File"))
	     (m-file-load (make-menubutton m-file "Load Module" 
				(lambda () (load-module startup lib-loader))))
	     (m-file-quit (make-menubutton m-file "Quit" 
					   (lambda () (destroy *tk*))))
	     )
	(declare (ignore m-file-load m-file-quit))
	(setf *text* txt)
	(wm-title *tk* "LIFP - Lisp Interactive Fiction Project")
	(pack txt :fill :both :expand :both)
	;;(pack status :side :left :expand t :fill :x) 
	(setf (text txt) "")
	(configure txt :font "courier")	
	(setf *console-on* (list txt))
        (force-focus *tk*)
	(unless interactive (funcall startup)))))
  (setf *console-on* nil))
  
(defun ltk-after (time fun)
  (if *repl-mode* (funcall fun)
      (ltk:after time fun)))

(defun close-console ()
  (unless *repl-mode*
    (center-text *text*)
    (let ((quit-button (make-instance 
                        'button
                        :text "Quit"
                        :command (lambda () (destroy *tk*)))))
      (insert-object *text* quit-button)
      (focus quit-button))))
    
				
(defun print-message (string &rest args)
  (if *repl-mode* (progn (apply #'format t string args) 
			 (terpri *standard-output*))
      (progn (configure *text* :state "normal")
	     (append-text *text* (apply #'format nil string args))
	     (append-text *text* (make-string 1 :initial-element #\Newline)))))