blob: b8b28d100b8ee65cd00d1229afb9718faf262761 (
about) (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
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
|
