;;; -*- mode: Lisp; Syntax: Common-Lisp; -*-
;;;
;;; Copyright (c) 2009 by the authors.
;;;
;;; See LICENCE for details.

(in-package :hu.dwim.projectional-editor)

;;;;;;
;;; Projection

(def (projection e) string->styled-string ()
  ((color-provider :type function)
   (font-provider :type function)))

;;;;;;
;;; Construction

(def (function e) make-projection/string->styled-string (&key color-provider font-provider)
  (make-projection 'string->styled-string
                   :color-provider color-provider
                   :font-provider font-provider))

;;;;;;
;;; Construction

(def (macro e) string->styled-string (&key color-provider font-provider)
  `(make-projection/string->styled-string :color-provider ,color-provider
                                          :font-provider ,font-provider))

;;;;;;
;;; Printer

(def printer string->styled-string (projection recursion input input-reference output-reference)
  (declare (ignore recursion))
  (bind ((child-iomaps nil)
         (stream (make-string-output-stream))
         (color nil)
         (font nil)
         (input-offset 0)
         (output-index 0)
         (elements (flet ((next-styled-string ()
                            (bind ((content (get-output-stream-string stream)))
                              (unless (string= content "")
                                (push (make-iomap/string input input-reference input-offset content
                                                         `(content-of (the styled-string/string (elt (the list (elements-of (the styled-string/document ,output-reference))) ,output-index))) 0 (length content))
                                      child-iomaps)
                                (incf output-index)
                                (list (make-styled-string/string content :color color :font font))))))
                     (iter (with color-provider = (color-provider-of projection))
                           (with font-provider = (font-provider-of projection))
                           (for character-index :from 0)
                           (for character :in-sequence input)
                           (for character-reference = `(the character (elt (the string ,input-reference) ,character-index)))
                           (for character-color = (or (when color-provider (funcall color-provider *iomap* character-reference))
                                                      sdl:*default-color*))
                           (for character-font = (or (when font-provider (funcall font-provider *iomap* character-reference))
                                                     sdl:*default-font*))
                           (when (or (not (sdl:color= color character-color))
                                     (not (eq font character-font)))
                             (appending (next-styled-string) :into styled-strings)
                             (setf stream (make-string-output-stream))
                             (setf input-offset character-index)
                             (setf color character-color)
                             (setf font character-font))
                           (write-char character stream)
                           (finally
                            (return (append styled-strings (next-styled-string)))))))
         (output (make-styled-string/document elements)))
    (make-iomap/recursive input output (list* (make-iomap/object input input-reference output output-reference) (nreverse child-iomaps)))))

;;;;;;
;;; Reader

(def reader string->styled-string (projection recursion input input-reference output-reference)
  (declare (ignore projection recursion input-reference output-reference))
  (bind ((latest-gesture (first (gestures-of input))))
    (cond ((and (typep latest-gesture 'gesture/keyboard/key-press)
                (member (key-of latest-gesture) '(:sdl-key-left :sdl-key-right :sdl-key-up :sdl-key-down)))
           ;; TODO:
           (make-operation/replace-selection nil))
          ((and (typep latest-gesture 'gesture/keyboard/key-press)
                (member (key-of latest-gesture) '(:sdl-key-home :sdl-key-end)))
           ;; TODO:
           (make-operation/replace-selection nil))
          ((and (typep latest-gesture 'gesture/keyboard/key-press)
                (member (key-of latest-gesture) '(:sdl-key-pageup :sdl-key-pagedown)))
           ;; TODO:
           (make-operation/replace-selection nil)))))