diff options
| -rw-r--r-- | org-fc-diff.el | 163 | ||||
| -rw-r--r-- | org-fc-type-text-input.el | 2 | ||||
| -rw-r--r-- | org-fc-type-vocab.el | 1 | ||||
| -rw-r--r-- | org-fc.el | 131 |
4 files changed, 166 insertions, 131 deletions
diff --git a/org-fc-diff.el b/org-fc-diff.el new file mode 100644 index 0000000..b8b28d1 --- /dev/null +++ b/org-fc-diff.el @@ -0,0 +1,163 @@ +;;; org-fc-diff.el --- String diff functions -*- lexical-binding: t; -*- + +;; Copyright (C) 2020-2021 Leon Rische + +;; Author: Leon Rische <emacs@leonrische.me> +;; Url: https://www.leonrische.me/pages/org_flashcards.html +;; Package-requires: ((emacs "26.3") (org "9.3")) +;; Version: 0.1.0 + +;; 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 this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Diff functions for text-input cards. +;; +;; Expected and given input are compared using a longest matching +;; subsequence algorithm and matching / differing sections are colored. +;; +;;; Code: + +(require 'cl-lib) + +(defcustom org-fc-diff-filler ?- + "Character for filling diffs when the input was too short." + :type 'character + :group 'org-fc) + +;; Based on `magit-diff-added' +(defface org-fc-diff-correct + `((((class color) (background light)) + :background "#ddffdd" + :foreground "#22aa22") + (((class color) (background dark)) + :background "#335533" + :foreground "#ddffdd")) + "Face for correct parts of a diff." + :group 'org-fc) + +;; Based on `magit-diff-removed' +(defface org-fc-diff-wrong + `((((class color) (background light)) + :background "#ffdddd" + :foreground "#aa2222") + (((class color) (background dark)) + :background "#553333" + :foreground "#ffdddd")) + "Face for wrong parts of a diff." + :group 'org-fc) + +(defun org-fc-diff-subseq (a b start1 start2 end1 end2) + "Find (index-a index-b len) of the longest matching subsequence in A and B. +Only parts of A in the range START1 to END1 and parts of B in the +range START2 to END2 are considered. +If there is no matching subsequence, nil is returned." + (let ((best-length 0) (best-i 0) (best-j 0) + ;; Longest matching subsequence starting at index j of B, + ;; offset by one to handle the case j = 0 + (lengths (make-vector (1+ (length b)) 0))) + (cl-loop for i from start1 to end1 do + (let ((new-lengths (make-vector (1+ (length b)) 0))) + (cl-loop for j from start2 to end2 do + (if (eql (aref a i) (aref b j)) + (let ((length (+ 1 (aref lengths j)))) + (aset new-lengths (1+ j) length) + (when (> length best-length) + (setq best-length length) + (setq best-i (1+ (- i length))) + (setq best-j (1+ (- j length))))))) + (setq lengths new-lengths))) + (if (> best-length 0) + (list best-i best-j best-length)))) + +(defun org-fc-diff-matching-blocks (a b start1 start2 end1 end2) + "Find matching blocks of A and B. +Only parts of A in the range START1 to END1 and parts of B in the +range START2 to END2 are considered." + (if-let ((match (org-fc-diff-subseq a b start1 start2 end1 end2))) + (cl-destructuring-bind (i j len) match + (append + (org-fc-diff-matching-blocks a b start1 start2 (1- i) (1- j)) + (list match) + (org-fc-diff-matching-blocks a b (+ i len) (+ j len) end1 end2))))) + +(defun org-fc-diff--propertize-got (got blocks expected-length) + "Propertize the GOT answer given matching BLOCKS. +If it is shorter than EXPECTED-LENGTH, it is filled using +`org-fc-diff-filler'." + (let ((last 0) res) + ;; Prepend filler if text at start is missing + (unless (null blocks) + (cl-destructuring-bind (i j _len) (car blocks) + (if (> j i) + (setq res + (propertize + (make-string (- j i) org-fc-diff-filler) + 'face 'org-fc-diff-wrong))))) + (cl-loop for (i _ len) in blocks do + (setq res + (concat + res + (propertize + (cl-subseq got last i) + 'face 'org-fc-diff-wrong) + (propertize + (cl-subseq got i (+ i len)) + 'face 'org-fc-diff-correct))) + (setq last (+ i len))) + (setq res + (concat + res + (propertize (cl-subseq got last) 'face 'org-fc-diff-wrong))) + ;; Append filler if result is shorter than expected + (if (< (length res) expected-length) + (concat + res + (propertize + (make-string (- expected-length (length res)) org-fc-diff-filler) + 'face 'org-fc-diff-wrong)) + res))) + +(defun org-fc-diff--propertize-expected (expected blocks) + "Propertize the EXPECTED answer, given matching BLOCKS." + (let ((last 0) res) + (cl-loop for (_ j len) in blocks do + (setq res + (concat + res + (cl-subseq expected last j) + (propertize + (cl-subseq expected j (+ j len)) + 'face 'org-fc-diff-correct))) + (setq last (+ j len))) + (concat res (cl-subseq expected last)))) + +(defun org-fc-diff (got expected) + "Generate a colored diff of the strings GOT and EXPECTED." + (if (string= got expected) + (cons (propertize got 'face 'org-fc-diff-correct) nil) + (let ((blocks (org-fc-diff-matching-blocks + got expected + 0 0 + (1- (length got)) + (1- (length expected))))) + (cons + (org-fc-diff--propertize-got got blocks (length expected)) + (org-fc-diff--propertize-expected expected blocks))))) + +;;; Footer + +(provide 'org-fc-diff) + +;;; org-fc-diff.el ends here diff --git a/org-fc-type-text-input.el b/org-fc-type-text-input.el index 6d8430c..63c63fb 100644 --- a/org-fc-type-text-input.el +++ b/org-fc-type-text-input.el @@ -24,6 +24,8 @@ ;; ;;; Code: +(require 'org-fc-diff) + (defun org-fc-text-input-content () "Return the first line of a cards (back) contents. Returns a pair (pos . string). If the card has a 'Back' heading, diff --git a/org-fc-type-vocab.el b/org-fc-type-vocab.el index f278049..26562e9 100644 --- a/org-fc-type-vocab.el +++ b/org-fc-type-vocab.el @@ -30,6 +30,7 @@ ;; ;;; Code: +(require 'org-fc-diff) (require 'org-fc-audio) (defcustom org-fc-type-vocab-slow-speed 0.7 @@ -166,37 +166,6 @@ Does not apply to cloze single and cloze enumeration cards." :type 'hook :group 'org-fc) -;;;; Diff - -(defcustom org-fc-diff-filler ?- - "Character for filling diffs when the input was too short." - :type 'character - :group 'org-fc) - -;;;; Font Faces - -;; Based on `magit-diff-added' -(defface org-fc-diff-correct - `((((class color) (background light)) - :background "#ddffdd" - :foreground "#22aa22") - (((class color) (background dark)) - :background "#335533" - :foreground "#ddffdd")) - "Face for correct parts of a diff." - :group 'org-fc) - -;; Based on `magit-diff-removed' -(defface org-fc-diff-wrong - `((((class color) (background light)) - :background "#ffdddd" - :foreground "#aa2222") - (((class color) (background dark)) - :background "#553333" - :foreground "#ffdddd")) - "Face for wrong parts of a diff." - :group 'org-fc) - ;;; Variables ;; Not customizable because the indexers / filters expect ISO8601 @@ -336,106 +305,6 @@ If point is not inside a flashcard entry, an error is raised." (goto-char pos) ,@body))) -;;; Diff - -(defun org-fc-diff-subseq (a b start1 start2 end1 end2) - "Find (index-a index-b len) of the longest matching subsequence in A and B. -Only parts of A in the range START1 to END1 and parts of B in the -range START2 to END2 are considered. -If there is no matching subsequence, nil is returned." - (let ((best-length 0) (best-i 0) (best-j 0) - ;; Longest matching subsequence starting at index j of B, - ;; offset by one to handle the case j = 0 - (lengths (make-vector (1+ (length b)) 0))) - (cl-loop for i from start1 to end1 do - (let ((new-lengths (make-vector (1+ (length b)) 0))) - (cl-loop for j from start2 to end2 do - (if (eql (aref a i) (aref b j)) - (let ((length (+ 1 (aref lengths j)))) - (aset new-lengths (1+ j) length) - (when (> length best-length) - (setq best-length length) - (setq best-i (1+ (- i length))) - (setq best-j (1+ (- j length))))))) - (setq lengths new-lengths))) - (if (> best-length 0) - (list best-i best-j best-length)))) - -(defun org-fc-diff-matching-blocks (a b start1 start2 end1 end2) - "Find matching blocks of A and B. -Only parts of A in the range START1 to END1 and parts of B in the -range START2 to END2 are considered." - (if-let ((match (org-fc-diff-subseq a b start1 start2 end1 end2))) - (cl-destructuring-bind (i j len) match - (append - (org-fc-diff-matching-blocks a b start1 start2 (1- i) (1- j)) - (list match) - (org-fc-diff-matching-blocks a b (+ i len) (+ j len) end1 end2))))) - -(defun org-fc-diff--propertize-got (got blocks expected-length) - "Propertize the GOT answer given matching BLOCKS. -If it is shorter than EXPECTED-LENGTH, it is filled using -`org-fc-diff-filler'." - (let ((last 0) res) - ;; Prepend filler if text at start is missing - (unless (null blocks) - (cl-destructuring-bind (i j _len) (car blocks) - (if (> j i) - (setq res - (propertize - (make-string (- j i) org-fc-diff-filler) - 'face 'org-fc-diff-wrong))))) - (cl-loop for (i _ len) in blocks do - (setq res - (concat - res - (propertize - (cl-subseq got last i) - 'face 'org-fc-diff-wrong) - (propertize - (cl-subseq got i (+ i len)) - 'face 'org-fc-diff-correct))) - (setq last (+ i len))) - (setq res - (concat - res - (propertize (cl-subseq got last) 'face 'org-fc-diff-wrong))) - ;; Append filler if result is shorter than expected - (if (< (length res) expected-length) - (concat - res - (propertize - (make-string (- expected-length (length res)) org-fc-diff-filler) - 'face 'org-fc-diff-wrong)) - res))) - -(defun org-fc-diff--propertize-expected (expected blocks) - "Propertize the EXPECTED answer, given matching BLOCKS." - (let ((last 0) res) - (cl-loop for (_ j len) in blocks do - (setq res - (concat - res - (cl-subseq expected last j) - (propertize - (cl-subseq expected j (+ j len)) - 'face 'org-fc-diff-correct))) - (setq last (+ j len))) - (concat res (cl-subseq expected last)))) - -(defun org-fc-diff (got expected) - "Generate a colored diff of the strings GOT and EXPECTED." - (if (string= got expected) - (cons (propertize got 'face 'org-fc-diff-correct) nil) - (let ((blocks (org-fc-diff-matching-blocks - got expected - 0 0 - (1- (length got)) - (1- (length expected))))) - (cons - (org-fc-diff--propertize-got got blocks (length expected)) - (org-fc-diff--propertize-expected expected blocks))))) - ;;; Checking for / going to flashcard headings (defun org-fc-entry-p () |