(defpackage :fwoar.lisp-sandbox.ot-edit
  (:use :cl )
  (:export
   #:edit
   #:insert
   #:editable-string
   #:apply-edits))
(in-package :fwoar.lisp-sandbox.ot-edit)

(defgeneric transform-for-op (op))
(defgeneric edit (base operation))
(defgeneric apply-edits (base operations))

(fw.lu:defclass+ editable-string ()
  ((%string :initarg :string :accessor string-to-edit)
   (%transform :accessor transform :initform 'identity)))

(defclass op ()
  ((%epoch :reader epoch :initform (let ((c (load-time-value (vector 0)))) (incf (elt c 0))))))

(defmethod apply-edits ((base string) (operations sequence))
  (string-to-edit
   (reduce 'edit
           (sort operations '< :key 'epoch)
           :initial-value (editable-string base))))

(fw.lu:defclass+ insert (op)
  ((%point :initarg :point :accessor point)
   (%value :initarg :value :reader value)))
(defmethod print-object ((o insert) s)
  (print-unreadable-object (o s :type t :identity t)
    (format s "~d/~d" (point o) (epoch o))))
(defmethod transform-for-op ((op insert))
  (let ((point (point op))
        (insert-length (length (value op))))
    (lambda (new-point)
      (if (< new-point point)
          new-point
          (+ new-point insert-length)))))
(defun do-insert (base new point)
  (let ((begin (subseq base 0 point))
        (end (subseq base point)))
    (concatenate 'string begin new end)))
(defmethod edit ((base editable-string) (operation insert))
  (let* ((current-transform (transform base))
         (op-point (point operation))
         (string-to-edit (string-to-edit base))
         (transformed-op (insert (funcall current-transform op-point)
                                 (value operation))))
    (setf (string-to-edit base) (do-insert string-to-edit (value transformed-op) (point transformed-op))
          (transform base) (alexandria:compose (transform-for-op transformed-op) current-transform))
    base))

(fw.lu:defclass+ replace-char (op)
  ((%point :initarg :point :accessor point)
   (%value :initarg :value :reader value)))
(defmethod print-object ((o replace-char) s)
  (print-unreadable-object (o s :type t :identity t)
    (format s "~d/~d" (point o) (epoch o))))
(defmethod transform-for-op ((op replace-char))
  (let ((point (point op))
        (insert-length (length (value op))))
    (lambda (new-point)
      (if (<= new-point point)
          new-point
          (+ new-point -1 insert-length)))))
(defun do-replace-char (base new point)
  (let ((begin (subseq base 0 point))
        (end (subseq base (1+ point))))
    (concatenate 'string begin new end)))
(defmethod edit ((base editable-string) (operation replace-char))
  (let* ((current-transform (transform base))
         (op-point (point operation))
         (string-to-edit (string-to-edit base))
         (transformed-op (replace-char (funcall current-transform op-point)
                                       (value operation))))
    (setf (string-to-edit base) (do-replace-char string-to-edit (value transformed-op) (point transformed-op))
          (transform base) (alexandria:compose (transform-for-op transformed-op) current-transform))
    base))


(defun sample ()
  (assert (equal (apply-edits "ac" (list (insert 0 "z")
                                         (insert 1 "b")
                                         (insert 2 "d")))
                 "zabcd"))
  (assert
   (let ((ops (list (insert 1 "fff")
                    (insert 1 "ggg")
                    (insert 1 "hhh"))))
     (list (equal (apply-edits #1="abcd" ops)
                  (apply-edits #1# (reverse ops)))
           (equal (apply-edits #1# (reverse ops))
                  (apply-edits #1# (serapeum:reshuffle ops)))
           (equal (apply-edits #1# (reverse ops))
                  "afffggghhhbcd"))))
  (let ((ops (lambda ()
               (list (insert 2 "fff")
                     (insert 1 "bbb")
                     (insert 1 "ddd")))))
    (:printv (funcall ops))
    (assert (equal (:printv (apply-edits "ac" (:printv (serapeum:reshuffle (funcall ops)))))
                   (:printv (apply-edits "ac" (:printv (serapeum:reshuffle (funcall ops)))))))
    (assert (equal (:printv (apply-edits "ace" (serapeum:reshuffle (funcall ops))))
                   (:printv (apply-edits "ace" (serapeum:reshuffle (funcall ops))))))))