;;; Starling Game Engine
;;; Copyright © 2020 David Thompson <davet@gnu.org>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Starling.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:
;;
;; Minibuffer for fast code execution.
;;
;;; Code:

(define-module (starling minibuffer)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics font)
  #:use-module (chickadee graphics path)
  #:use-module (chickadee math rect)
  #:use-module (chickadee math vector)
  #:use-module (chickadee scripting)
  #:use-module (ice-9 match)
  #:use-module (oop goops)
  #:use-module (srfi srfi-1)
  #:use-module (starling node)
  #:use-module (starling node-2d)
  #:use-module (starling scene)
  #:export (<minibuffer>
            add-minibuffer-command
            define-minibuffer-command
            open-minibuffer))

(define-class <minibuffer> (<scene-2d>)
  (commands #:accessor commands #:allocation #:class #:init-thunk make-hash-table)
  (scene-mux #:getter scene-mux #:init-keyword #:scene-mux)
  (overlay-scene #:accessor overlay-scene)
  (user-text #:accessor user-text #:init-form ""))

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

(define-method (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 (open-minibuffer minibuffer)
  (set! (overlay-scene minibuffer) (current-scene (scene-mux minibuffer)))
  (push-scene (scene-mux minibuffer) minibuffer))

(define-method (close-minibuffer (minibuffer <minibuffer>))
  (pop-scene (scene-mux minibuffer)))

(define-method (run-command (minibuffer <minibuffer>))
  (let ((thunk (hash-ref (minibuffer-commands) (user-text minibuffer))))
    (when (procedure? thunk)
      (modify-user-text minibuffer "")
      (close-minibuffer minibuffer)
      (thunk))))

(define-method (modify-user-text (minibuffer <minibuffer>) new-text)
  (set! (user-text minibuffer) new-text)
  (set! (text (& minibuffer text-entry))
    (string-append "> " new-text)))

(define-method (backward-delete (minibuffer <minibuffer>))
  (let ((text (user-text minibuffer)))
    (modify-user-text minibuffer
                      (substring text 0 (max (- (string-length text) 1) 0)))))

(define-method (tab-complete (minibuffer <minibuffer>))
  (let ((prefix (user-text minibuffer)))
    ;; 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)
       (modify-user-text minibuffer name))
      (_ #f))))

(define-method (on-boot (minibuffer <minibuffer>))
  (let* ((res (resolution (car (cameras minibuffer))))
         (font (default-font))
         (line-height (font-line-height font))
         (padding 8.0))
    (attach-to minibuffer
               (make <canvas>
                 #:painter (with-style ((fill-color (make-color 0 0 0 0.7)))
                             (fill
                              (rectangle (vec2 0.0 0.0)
                                         (vec2-x res)
                                         (+ line-height (* padding 2.0))))))
               (make <label>
                 #:name 'text-entry
                 #:rank 9
                 #:font font
                 #:position (vec2 padding padding)))
    (modify-user-text minibuffer "")))

(define-method (update (minibuffer <minibuffer>) dt)
  (update-tree (overlay-scene minibuffer) dt)
  (next-method))

(define-method (render (minibuffer <minibuffer>) alpha)
  (render-tree (overlay-scene minibuffer) alpha)
  (next-method))

(define-method (on-key-press (minibuffer <minibuffer>) key modifiers repeat?)
  (match key
    ('escape (close-minibuffer minibuffer))
    ('return (run-command minibuffer))
    ('backspace (backward-delete minibuffer))
    ('tab (tab-complete minibuffer))
    (_ #f)))

(define-method (on-text-input (minibuffer <minibuffer>) text)
  (modify-user-text minibuffer (string-append (user-text minibuffer) text)))