Browse code
feat(ot-edit): simple insert/one-character replace OTs for strings
Edward authored on 25/02/2021 10:21:15Showing 1 changed files
| 1 | 1 |
new file mode 100644 |
| ... | ... |
@@ -0,0 +1,78 @@ |
| 1 |
+(defpackage :fwoar.lisp-sandbox.ot-edit |
|
| 2 |
+ (:use :cl ) |
|
| 3 |
+ (:export |
|
| 4 |
+ #:edit |
|
| 5 |
+ #:insert |
|
| 6 |
+ #:editable-string |
|
| 7 |
+ #:apply-edits)) |
|
| 8 |
+(in-package :fwoar.lisp-sandbox.ot-edit) |
|
| 9 |
+ |
|
| 10 |
+(defgeneric transform-for-op (op)) |
|
| 11 |
+(defgeneric edit (base operation)) |
|
| 12 |
+(defgeneric apply-edits (base operations)) |
|
| 13 |
+ |
|
| 14 |
+ |
|
| 15 |
+(fw.lu:defclass+ replace-char () |
|
| 16 |
+ ((%point :initarg :point :accessor point) |
|
| 17 |
+ (%value :initarg :value :reader value))) |
|
| 18 |
+(defmethod transform-for-op ((op replace-char)) |
|
| 19 |
+ (let ((point (point op)) |
|
| 20 |
+ (insert-length (length (value op)))) |
|
| 21 |
+ (lambda (new-point) |
|
| 22 |
+ (if (<= new-point point) |
|
| 23 |
+ new-point |
|
| 24 |
+ (+ new-point -1 insert-length))))) |
|
| 25 |
+ |
|
| 26 |
+(fw.lu:defclass+ insert () |
|
| 27 |
+ ((%point :initarg :point :accessor point) |
|
| 28 |
+ (%value :initarg :value :reader value))) |
|
| 29 |
+(defmethod transform-for-op ((op insert)) |
|
| 30 |
+ (let ((point (point op)) |
|
| 31 |
+ (insert-length (length (value op)))) |
|
| 32 |
+ (lambda (new-point) |
|
| 33 |
+ (if (< new-point point) |
|
| 34 |
+ new-point |
|
| 35 |
+ (+ new-point insert-length))))) |
|
| 36 |
+ |
|
| 37 |
+(fw.lu:defclass+ editable-string () |
|
| 38 |
+ ((%string :initarg :string :accessor string-to-edit) |
|
| 39 |
+ (%transform :accessor transform :initform 'identity))) |
|
| 40 |
+ |
|
| 41 |
+(defmethod apply-edits ((base string) (operations sequence)) |
|
| 42 |
+ (string-to-edit |
|
| 43 |
+ (reduce 'edit |
|
| 44 |
+ operations |
|
| 45 |
+ :initial-value (editable-string base)))) |
|
| 46 |
+ |
|
| 47 |
+(defun do-insert (base new point) |
|
| 48 |
+ (let ((begin (subseq base 0 point)) |
|
| 49 |
+ (end (subseq base point))) |
|
| 50 |
+ (concatenate 'string begin new end))) |
|
| 51 |
+(defmethod edit ((base editable-string) (operation insert)) |
|
| 52 |
+ (let ((current-transform (transform base)) |
|
| 53 |
+ (op-point (point operation)) |
|
| 54 |
+ (string-to-edit (string-to-edit base))) |
|
| 55 |
+ (setf (point operation) (funcall current-transform op-point) |
|
| 56 |
+ (string-to-edit base) (do-insert string-to-edit (value operation) (point operation)) |
|
| 57 |
+ (transform base) (alexandria:compose (transform-for-op operation) current-transform)) |
|
| 58 |
+ base)) |
|
| 59 |
+(defun do-replace-char (base new point) |
|
| 60 |
+ (let ((begin (subseq base 0 point)) |
|
| 61 |
+ (end (subseq base (1+ point)))) |
|
| 62 |
+ (concatenate 'string begin new end))) |
|
| 63 |
+(defmethod edit ((base editable-string) (operation replace-char)) |
|
| 64 |
+ (let ((current-transform (transform base)) |
|
| 65 |
+ (op-point (point operation)) |
|
| 66 |
+ (string-to-edit (string-to-edit base))) |
|
| 67 |
+ (setf (point operation) (funcall current-transform op-point) |
|
| 68 |
+ (string-to-edit base) (do-replace-char string-to-edit (value operation) (point operation)) |
|
| 69 |
+ (transform base) (alexandria:compose (transform-for-op operation) current-transform)) |
|
| 70 |
+ base)) |
|
| 71 |
+ |
|
| 72 |
+ |
|
| 73 |
+(defun sample () |
|
| 74 |
+ "ac" |
|
| 75 |
+ '(insert "b" 1) |
|
| 76 |
+ "abc" |
|
| 77 |
+ '(insert "d" 2) |
|
| 78 |
+ "abdc") |