;;; Catbird Game Engine
;;; Copyright © 2022 David Thompson <davet@gnu.org>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;
;; Emacs-like minibuffer for command entry.
;;
;;; Code:
(define-module (catbird minibuffer)
  #:use-module (catbird kernel)
  #:use-module (catbird line-editor)
  #:use-module (catbird mixins)
  #:use-module (catbird mode)
  #:use-module (catbird node)
  #:use-module (catbird node-2d)
  #:use-module (catbird region)
  #:use-module (catbird scene)
  #:use-module (chickadee)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics path)
  #:use-module (chickadee graphics text)
  #:use-module (chickadee math vector)
  #:use-module (chickadee scripting)
  #:use-module (ice-9 match)
  #:use-module (oop goops)
  #:export (<minibuffer>
            <minibuffer-mode>
            define-minibuffer-command))

(define %background-color (make-color 0.0 0.0 0.0 0.8))
(define %prompt "> ")
(define %padding 8.0)

(define-class <minibuffer> (<node-2d>)
  (commands #:accessor commands #:allocation #:class
            #:init-thunk make-hash-table))

(define (minibuffer-commands)
  (class-slot-ref <minibuffer> 'commands))

(define (lookup-minibuffer-command name)
  (hash-ref (minibuffer-commands) name))

(define (add-minibuffer-command name thunk)
  (hash-set! (minibuffer-commands) name thunk))

(define-syntax-rule (define-minibuffer-command name body ...)
  (add-minibuffer-command (symbol->string 'name) (lambda () body ...)))

(define-method (initialize (minibuffer <minibuffer>) initargs)
  (next-method)
  (attach-to minibuffer
             (make <canvas>
               #:name 'background)
             (make <line-editor>
               #:name 'editor
               #:rank 1
               #:position (vec2 %padding %padding)
               #:prompt %prompt)))

(define-method (resize-minibuffer (minibuffer <minibuffer>) width)
  (let ((bg (& minibuffer background)))
    (set! (painter bg)
          (with-style ((fill-color %background-color))
            (fill
             (rectangle (vec2 0.0 0.0)
                        width
                        (+ (font-line-height (font (& minibuffer editor)))
                           (* %padding 2.0))))))
    (resize bg)))

(define-method (clear-minibuffer (minibuffer <minibuffer>))
  (clear-line (& minibuffer editor)))

;; TODO: The line editor should have a generic completion facility.
(define-method (autocomplete (minibuffer <minibuffer>))
  (let ((prefix (get-line (& minibuffer editor))))
    ;; Auto-complete if there is a single command name that starts
    ;; with the characters the user has already typed.
    (match (hash-fold (lambda (key value prev)
                        (if (string-prefix? prefix key)
                            (cons key prev)
                            prev))
                      '()
                      (minibuffer-commands))
      ((name)
       (overwrite (& minibuffer editor) name))
      ;; TODO: Display multiple completion options to user.
      (_ #f))))

(define-method (get-command (minibuffer <minibuffer>))
  (lookup-minibuffer-command (get-line (& minibuffer editor))))

(define-method (valid-command? (minibuffer <minibuffer>))
  (procedure? (get-command minibuffer)))

(define-method (run-command (minibuffer <minibuffer>))
  (let ((thunk (get-command minibuffer)))
    (save-to-history (& minibuffer editor))
    (when (procedure? thunk)
      (thunk))))


;;;
;;; Minibuffer major mode
;;;

(define-class <minibuffer-mode> (<major-mode>)
  (prev-keyboard-focus #:accessor prev-keyboard-focus))

(define-method (on-enter (mode <minibuffer-mode>))
  (let* ((scene (parent mode))
         (region (car (regions scene)))
         (minibuffer (or (& scene minibuffer)
                         (make <minibuffer>
                           #:name 'minibuffer
                           #:rank 999))))
    (if (parent minibuffer)
        (begin
          (clear-minibuffer minibuffer)
          (show (& scene minibuffer)))
        (attach-to (parent mode) minibuffer))
    (resize-minibuffer minibuffer (area-width region))
    (set! (prev-keyboard-focus mode) (current-keyboard-focus))
    (take-keyboard-focus region)
    (add-minor-mode scene (make <line-edit-mode>
                            #:editor (& scene minibuffer editor)))))

(define-method (on-exit (mode <minibuffer-mode>))
  (hide (& (parent mode) minibuffer))
  (remove-minor-mode (parent mode) <line-edit-mode>)
  (take-keyboard-focus (prev-keyboard-focus mode)))

(define-method (close-minibuffer (mode <minibuffer-mode>))
  (pop-major-mode (parent mode)))

(define-method (autocomplete (mode <minibuffer-mode>))
  (autocomplete (& (parent mode) minibuffer)))

(define-method (run-command (mode <minibuffer-mode>))
  ;; The minibuffer needs to be closed before running the command so
  ;; that this mode is no longer active and we've had a chance to
  ;; clean up the state of the overlay scene.
  (let ((minibuffer (& (parent mode) minibuffer)))
    (when (valid-command? minibuffer)
      (close-minibuffer mode)
      (run-command minibuffer))))

(bind-input <minibuffer-mode> (key-press 'escape) close-minibuffer)
(bind-input <minibuffer-mode> (key-press 'g '(ctrl)) close-minibuffer)
(bind-input <minibuffer-mode> (key-press 'tab) autocomplete)
(bind-input <minibuffer-mode> (key-press 'return) run-command)


;;;
;;; Basic minibuffer commands
;;;

(define (for-each-user-scene proc)
  (for-each (lambda (region)
              (unless (eq? (name region) 'overlay)
                (let ((s (scene region)))
                  (and s (proc s)))))
            (all-regions)))

;; General purpose built-in commands.
(define-minibuffer-command pause (for-each-user-scene pause))
(define-minibuffer-command resume (for-each-user-scene resume))
(define-minibuffer-command quit (abort-game))