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

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

;;;;;;;;
;;;; This file contains random code fragments that may or may not be valuable in the future.
;;;; Do not put this file into the system definition and do not load it with ASDF.
;;;;;;
;;; Mapping classes

(def class* mapping ()
  ((forward-mapping (make-hash-table :test 'equal) :type hash-table)
   (backward-mapping (make-hash-table :test 'equal) :type hash-table)))

;;;;;;
;;; Mapping constructors

(def (function e) make-mapping ()
  (make-instance 'mapping))

;;;;;;
;;; Mapping API implementation

(def method mapping? (object)
  (typep object 'mapping))

(def method insert-mapping ((mapping mapping) input output  &optional discriminator)
  (setf (gethash (make-discriminator input discriminator) (forward-mapping-of mapping)) output)
  (setf (gethash (make-discriminator output discriminator) (backward-mapping-of mapping)) input))

(def method remove-mapping ((mapping mapping) input output &optional discriminator)
  (remhash (make-discriminator input discriminator) (forward-mapping-of mapping))
  (remhash (make-discriminator output discriminator) (backward-mapping-of mapping)))

(def (function e) insert-string-mapping (mapping input output length  &key (input-offset 0) (output-offset 0) discriminator)
  (insert-mapping mapping `(the string ,input) `(the string ,output) discriminator)
  (unless (and (zerop input-offset)
               (zerop output-offset))
    (insert-character-mapping mapping input output length
                              :input-offset input-offset
                              :output-offset output-offset)))

(def (function e) insert-character-mapping (mapping input output length &key (input-offset 0) (output-offset 0))
  (iter (for index :from 0 :to length)
        (for input-index = (+ input-offset index))
        (for output-index = (+ output-offset index))
        (unless (= index length)
          (insert-mapping mapping `(the character (elt (the string ,input) ,input-index)) `(the character (elt (the string ,output) ,output-index))))
        (insert-mapping mapping `(sequence-position (the string ,input) ,input-index) `(sequence-position (the string ,output) ,output-index))))

(def function map-reference (mapping input-reference &optional discriminator)
  (bind ((output-reference (gethash (make-discriminator input-reference discriminator) mapping)))
    (pattern-case input-reference
      ;; FIXME: TODO: this may map some characters which we actually do not want to map
      ((the character (elt (the string ?a) ?b))
       (or output-reference
           (bind ((string-output-reference (gethash (make-discriminator `(the string ,?a) discriminator) mapping)))
             (when string-output-reference
               `(the character (elt ,string-output-reference ,?b))))))
      ((sequence-position (the string ?a) ?b)
       (or output-reference
           (bind ((string-output-reference (gethash (make-discriminator `(the string ,?a) discriminator) mapping)))
             (when string-output-reference
               `(sequence-position ,string-output-reference ,?b)))))
      (?a
       output-reference))))

;; TODO: remove projection-image from output
;; TODO: should map the reference in the innermost projection-image
(def (function e) map-reference-forward (mapping input-reference &optional discriminator)
  (bind ((forward-mapping (forward-mapping-of mapping)))
    (labels ((recurse (reference)
               (or (map-reference forward-mapping reference discriminator)
                   (pattern-case reference
                     ((the ?a ?b)
                      (awhen (recurse ?b)
                        `(the ,?a ,it)))
                     ((elt ?a ?b)
                      (awhen (recurse ?a)
                        `(elt ,it ,?b)))
                     ((sequence-position ?a ?b)
                      (awhen (recurse ?a)
                        `(sequence-position ,it ,?b)))
                     ((separator ?a ?b)
                      (when-bind a (recurse ?a)
                        (when-bind b (recurse ?b)
                          `(separator ,a ,b))))
                     ((?a ?b)
                      (awhen (recurse ?b)
                        `(,?a ,it)))))))
      (recurse input-reference))))

;; TODO: insert projection-image into output
;; TODO: should map the outermost reference and wrap with projection-image
(def (function e) map-reference-backward (mapping output-reference &optional discriminator)
  (bind ((backward-mapping (backward-mapping-of mapping)))
    (labels ((recurse (reference)
               (or (map-reference backward-mapping reference discriminator)
                   (pattern-case reference
                     ((the ?a ?b)
                      (awhen (recurse ?b)
                        `(the ,?a ,it)))
                     ((elt ?a ?b)
                      (awhen (recurse ?a)
                        `(elt ,it ,?b)))
                     ((sequence-position ?a ?b)
                      (awhen (recurse ?a)
                        `(sequence-position ,it ,?b)))
                     ((separator ?a ?b)
                      (when-bind a (recurse ?a)
                        (when-bind b (recurse ?b)
                          `(separator ,a ,b))))
                     ((?a ?b)
                      (awhen (recurse ?b)
                        `(,?a ,it)))))))
      (recurse output-reference))))

(def (function e) print-mapping (mapping &optional (stream t))
  (flet ((print-entry (key value)
           (format stream "   ~S -> ~S~%" key value)))
    (format stream "Forward mapping:~%")
    (maphash #'print-entry (forward-mapping-of mapping))
    (format stream "Backward mapping:~%")
    (maphash #'print-entry (backward-mapping-of mapping))))
;;;;;;
;;; Mapping classes

(def class* mapping ()
  ((forward-mapping (make-hash-table :test 'equal) :type hash-table)
   (backward-mapping (make-hash-table :test 'equal) :type hash-table)))

;;;;;;
;;; Mapping constructors

(def (function e) make-mapping ()
  (make-instance 'mapping))

;;;;;;
;;; Mapping API implementation

(def method mapping? (object)
  (typep object 'mapping))

(def method insert-mapping ((mapping mapping) input output  &optional discriminator)
  (setf (gethash (make-discriminator input discriminator) (forward-mapping-of mapping)) output)
  (setf (gethash (make-discriminator output discriminator) (backward-mapping-of mapping)) input))

(def method remove-mapping ((mapping mapping) input output &optional discriminator)
  (remhash (make-discriminator input discriminator) (forward-mapping-of mapping))
  (remhash (make-discriminator output discriminator) (backward-mapping-of mapping)))

(def (function e) insert-string-mapping (mapping input output length  &key (input-offset 0) (output-offset 0) discriminator)
  (insert-mapping mapping `(the string ,input) `(the string ,output) discriminator)
  (unless (and (zerop input-offset)
               (zerop output-offset))
    (insert-character-mapping mapping input output length
                              :input-offset input-offset
                              :output-offset output-offset)))

(def (function e) insert-character-mapping (mapping input output length &key (input-offset 0) (output-offset 0))
  (iter (for index :from 0 :to length)
        (for input-index = (+ input-offset index))
        (for output-index = (+ output-offset index))
        (unless (= index length)
          (insert-mapping mapping `(the character (elt (the string ,input) ,input-index)) `(the character (elt (the string ,output) ,output-index))))
        (insert-mapping mapping `(sequence-position (the string ,input) ,input-index) `(sequence-position (the string ,output) ,output-index))))

(def function map-reference (mapping input-reference &optional discriminator)
  (bind ((output-reference (gethash (make-discriminator input-reference discriminator) mapping)))
    (pattern-case input-reference
      ;; FIXME: TODO: this may map some characters which we actually do not want to map
      ((the character (elt (the string ?a) ?b))
       (or output-reference
           (bind ((string-output-reference (gethash (make-discriminator `(the string ,?a) discriminator) mapping)))
             (when string-output-reference
               `(the character (elt ,string-output-reference ,?b))))))
      ((sequence-position (the string ?a) ?b)
       (or output-reference
           (bind ((string-output-reference (gethash (make-discriminator `(the string ,?a) discriminator) mapping)))
             (when string-output-reference
               `(sequence-position ,string-output-reference ,?b)))))
      (?a
       output-reference))))

;; TODO: remove projection-image from output
;; TODO: should map the reference in the innermost projection-image
(def (function e) map-reference-forward (mapping input-reference &optional discriminator)
  (bind ((forward-mapping (forward-mapping-of mapping)))
    (labels ((recurse (reference)
               (or (map-reference forward-mapping reference discriminator)
                   (pattern-case reference
                     ((the ?a ?b)
                      (awhen (recurse ?b)
                        `(the ,?a ,it)))
                     ((elt ?a ?b)
                      (awhen (recurse ?a)
                        `(elt ,it ,?b)))
                     ((sequence-position ?a ?b)
                      (awhen (recurse ?a)
                        `(sequence-position ,it ,?b)))
                     ((separator ?a ?b)
                      (when-bind a (recurse ?a)
                        (when-bind b (recurse ?b)
                          `(separator ,a ,b))))
                     ((?a ?b)
                      (awhen (recurse ?b)
                        `(,?a ,it)))))))
      (recurse input-reference))))

;; TODO: insert projection-image into output
;; TODO: should map the outermost reference and wrap with projection-image
(def (function e) map-reference-backward (mapping output-reference &optional discriminator)
  (bind ((backward-mapping (backward-mapping-of mapping)))
    (labels ((recurse (reference)
               (or (map-reference backward-mapping reference discriminator)
                   (pattern-case reference
                     ((the ?a ?b)
                      (awhen (recurse ?b)
                        `(the ,?a ,it)))
                     ((elt ?a ?b)
                      (awhen (recurse ?a)
                        `(elt ,it ,?b)))
                     ((sequence-position ?a ?b)
                      (awhen (recurse ?a)
                        `(sequence-position ,it ,?b)))
                     ((separator ?a ?b)
                      (when-bind a (recurse ?a)
                        (when-bind b (recurse ?b)
                          `(separator ,a ,b))))
                     ((?a ?b)
                      (awhen (recurse ?b)
                        `(,?a ,it)))))))
      (recurse output-reference))))

(def (function e) print-mapping (mapping &optional (stream t))
  (flet ((print-entry (key value)
           (format stream "   ~S -> ~S~%" key value)))
    (format stream "Forward mapping:~%")
    (maphash #'print-entry (forward-mapping-of mapping))
    (format stream "Backward mapping:~%")
    (maphash #'print-entry (backward-mapping-of mapping))))



(def method project-reference (document projection reference)
  (map-reference-forward (mapping-of (source-of (project-document document projection))) reference))

(def (function e) iterate-reference-forward (document reference function)
  (declare (ignore document reference function))
  (not-yet-implemented))

(def (function e) iterate-reference-backward (document reference function &optional discriminators)
  (iter (for current-discriminator :initially discriminators :then (if discriminators (cdr discriminators) nil))
        (for current-source :initially (source-of document) :then (source-of current-document))
        (for current-reference :initially reference :then (when current-source (map-reference-backward (mapping-of current-source) current-reference (car current-discriminator))))
        (for current-document :initially document :then (when current-source (document-of current-source)))
        (while (and current-reference current-source current-document))
        (funcall function current-document current-reference)))
















(def method print-to-device (document (projection projection) (display device/display/sdl))
  ;; TODO: KLUDGE: selection display
  (bind ((graphics-document (project-document document projection))
         (selection-document (project-document (make-document (hu.dwim.walker:walk-form (selection-of document)))
                                               (make-projection/sequential
                                                (list (make-projection/walked-lisp-form-to-lisp-form)
                                                      (make-projection/lisp-form-to-tree)
                                                      (make-projection/tree-to-text :indentation-provider (make-indentation-provider :indent-width 2 :wrap-from 1))
                                                      (make-projection/text-to-graphics :color-provider 'walked-lisp-form-color-provider))))))
    (incf (location-of (content-of selection-document)) (make-2d 0 (+ 20 (2d-y (size-of (make-bounding-rectangle (content-of graphics-document)))))))
    (push (content-of selection-document) (elements-of (content-of graphics-document)))
    (print-to-device graphics-document (make-projection/graphics-to-sdl) display)))

(def method print-to-device (graphics-document (projection projection/graphics-to-sdl) (display device/display/sdl))
  (bind ((*translation* (make-2d 0 0)))
    (print-to-device (content-of graphics-document) projection display))
  #+nil
  (bind ((selection (selection-of projection)))
    (etypecase selection
      (null (values))
      (selection/single
       (bind ((rectangle (make-bounding-rectangle (target-of selection))))
         (print-to-device (make-graphics/rectangle (- (location-of rectangle)
                                                      (make-2d 1 1))
                                                   (+ (size-of rectangle)
                                                      (make-2d 2 2))
                                                   :stroke-color sdl:*red*)
                          projection
                          display))))))






;; recursive projection

(bind ((projection/recursive nil))
    (setf projection/recursive
          (lambda (projection recursion input input-reference output-reference)
            (declare (ignore recursion))
            (funcall (printer-of projection) projection projection/recursive input input-reference output-reference))))