src/TeXmacs/progs/version/version-edit.scm

   1
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;
   4 ;; MODULE      : version-edit.scm
   5 ;; DESCRIPTION : editing routines for versioning
   6 ;; COPYRIGHT   : (C) 2010  Joris van der Hoeven
   7 ;;
   8 ;; This software falls under the GNU general public license version 3 or later.
   9 ;; It comes WITHOUT ANY WARRANTY WHATSOEVER. For details, see the file LICENSE
  10 ;; in the root directory or <http://www.gnu.org/licenses/gpl-3.0.html>.
  11 ;;
  12 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  13
  14 (texmacs-module (version version-edit)
  15   (:use (version version-drd)))
  16
  17 (tm-define (version-context? t)
  18   (version-tag? (tree-label t)))
  19
  20 (tm-define (inside-version?)
  21   (not (not (tree-innermost version-context?))))
  22
  23 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  24 ;; Moving across the differences between both versions
  25 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  26
  27 (tm-define (version-first-difference)
  28   (go-start)
  29   (go-to-next-tag (group-resolve 'version-tag)))
  30
  31 (tm-define (version-previous-difference)
  32   (go-to-previous-tag (group-resolve 'version-tag)))
  33
  34 (tm-define (version-next-difference)
  35   (go-to-next-tag (group-resolve 'version-tag)))
  36
  37 (tm-define (version-last-difference)
  38   (go-end)
  39   (go-to-previous-tag (group-resolve 'version-tag)))
  40
  41 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  42 ;; Specify which version to show
  43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  44
  45 (tm-define (version-show-both)
  46   (:context version-context?)
  47   (variant-replace version-context? 'version-both))
  48
  49 (tm-define (version-show-old)
  50   (:context version-context?)
  51   (variant-replace version-context? 'version-old))
  52
  53 (tm-define (version-show-new)
  54   (:context version-context?)
  55   (variant-replace version-context? 'version-new))
  56
  57 (tm-define (version-show-all tag)
  58   (tree-replace (buffer-tree) version-context? tag))
  59
  60 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  61 ;; Retaining only one version
  62 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  63
  64 (tm-define (version-retain-current)
  65   (:context version-context?)
  66   (variant-replace version-context? 'version-both))
  67
  68 (tm-define (version-retain-old)
  69   (with-innermost t version-context?
  70     (tree-set t (tree-ref t 0))
  71     (version-next-difference)))
  72
  73 (tm-define (version-retain-new)
  74   (with-innermost t version-context?
  75     (tree-set t (tree-ref t 1))
  76     (version-next-difference)))
  77
  78 (tm-define (version-retain-current)
  79   (:inside version-old)
  80   (version-retain-old))
  81
  82 (tm-define (version-retain-current)
  83   (:inside version-new version-both)
  84   (version-retain-new))
  85
  86 (tm-define (version-retain-all which)
  87   (tree-replace (buffer-tree) version-context?
  88                 (lambda (t)
  89                   (cond ((number? which)
  90                          (tree-set t (tree-ref t which)))
  91                         ((tree-is? t 'version-old)
  92                          (tree-set t (tree-ref t 0)))
  93                         (else
  94                          (tree-set t (tree-ref t 1)))))))
  95
  96 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  97 ;; Finding a long common subsequence where to break
  98 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  99
 100 (define (common l1 l2)
 101   (if (or (null? l1) (null? l2) (!= (car l1) (car l2))) 0
 102       (+ (common (cdr l1) (cdr l2)) 1)))
 103
 104 (define (longest-common l1 l2)
 105   ;;(display* "longest-common " l1 ", " l2 "\n")
 106   (cond ((or (null? l1) (null? l2))
 107          (values 0 0 0))
 108         ((in? (car l1) l2)
 109          (let* ((i (list-find-index l2 (lambda (x) (== x (car l1)))))
 110                 (r2 (list-tail l2 i))
 111                 (n (common l1 r2)))
 112            (if (>= n 25) (values 0 i n) ;; truncate for efficiency reasons
 113                (receive (i1 i2 nn) (longest-common l1 (cdr r2))
 114                  (if (>= n nn)
 115                      (values 0 i n)
 116                      (values i1 (+ i2 i 1) nn))))))
 117         (else
 118           (receive (i1 i2 n) (longest-common (cdr l1) l2)
 119             (values (+ i1 1) i2 n)))))
 120
 121 (define (skeleton t)
 122   (if (string? t) 'concat (car t)))
 123
 124 (define (var-longest-common l1 l2)
 125   (receive (i1 i2 n) (longest-common l1 l2)
 126     (if (> n 0) (values i1 i2 n)
 127         (longest-common (map skeleton l1) (map skeleton l2)))))
 128
 129 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 130 ;; Show old and new versions into a single document
 131 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 132
 133 (define (diff t1 t2)
 134   ;;(display* "diff " t1 ", " t2 "\n")
 135   (cond ((and (or (string? t1) (!= (car t1) 'document))
 136               (tree-multi-paragraph? (tm->tree t2)))
 137          (diff `(document ,t1) t2))
 138         ((and (or (string? t2) (!= (car t2) 'document))
 139               (tree-multi-paragraph? (tm->tree t1)))
 140          (diff t1 `(document ,t2)))
 141         (else `(version-both ,t1 ,t2))))
 142
 143 (define (merge-versions-string s1 s2)
 144   (let* ((l1 (string->list s1))
 145          (l2 (string->list s2))
 146          (i1 (common l1 l2))
 147          (i2 (common (reverse (list-tail l1 i1)) (reverse (list-tail l2 i1))))
 148          (n1 (string-length s1))
 149          (n2 (string-length s2))
 150          (j1 (- n1 i2))
 151          (j2 (- n2 i2))
 152          (r1 (substring s1 0 i1))
 153          (r2 (diff (substring s1 i1 j1) (substring s2 i1 j2)))
 154          (r3 (substring s1 j1 n1)))
 155     (cond ((and (== i1 0) (== i2 0)) r2)
 156           ((== i1 0) `(concat ,r2 ,r3))
 157           ((== i2 0) `(concat ,r1 ,r2))
 158           (else `(concat ,r1 ,r2 ,r3)))))
 159
 160 (define (merge-versions-list tag l1 l2)
 161   ;;(display* "merge-versions-list " tag ", " l1 ", " l2 "\n\n")
 162   (cond ((and (null? l1) (null? l2)) '())
 163         ((null? l1) (list (diff "" `(,tag ,@l2))))
 164         ((null? l2) (list (diff `(,tag ,@l1) "")))
 165         ((== (car l1) (car l2))
 166          (cons (car l1) (merge-versions-list tag (cdr l1) (cdr l2))))
 167         (else
 168           (receive (i1 i2 n)
 169               (if (== tag 'concat)
 170                   (longest-common l1 l2)
 171                   (var-longest-common l1 l2))
 172             ;;(display* "  break at " i1 ", " i2 ", " n "\n")
 173             (cond ((== n 0)
 174                    (list (diff `(,tag ,@l1) `(,tag ,@l2))))
 175                   ((and (== n (length l1)) (== n (length l2)))
 176                    (map merge-versions l1 l2))
 177                   (else
 178                     (let* ((ll1 (sublist l1 0 i1))
 179                            (ll2 (sublist l2 0 i2))
 180                            (mm1 (sublist l1 i1 (+ i1 n)))
 181                            (mm2 (sublist l2 i2 (+ i2 n)))
 182                            (rr1 (sublist l1 (+ i1 n) (length l1)))
 183                            (rr2 (sublist l2 (+ i2 n) (length l2))))
 184                       (append (merge-versions-list tag ll1 ll2)
 185                               (merge-versions-list tag mm1 mm2)
 186                               (merge-versions-list tag rr1 rr2)))))))))
 187
 188 (tm-define (merge-versions t1 t2)
 189   ;;(display* "merge-versions " t1 ", " t2 "\n\n")
 190   (cond ((== t1 t2) t1)
 191         ((and (string? t1) (string? t2))
 192          (merge-versions-string t1 t2))
 193         ((and (string? t1) (tm-is? t2 'concat))
 194          (merge-versions `(concat ,t1) t2))
 195         ((and (tm-is? t1 'concat) (string? t2))
 196          (merge-versions t1 `(concat ,t2)))
 197         ((and (list? t1) (list? t2) (== (car t1) (car t2)))
 198          (cond ((in? (car t1) '(document concat))
 199                 (cons (car t1)
 200                       (merge-versions-list (car t1) (cdr t1) (cdr t2))))
 201                ((!= (length t1) (length t2))
 202                 (diff t1 t2))
 203                ((in? (car t1) '(raw-data value graphics postscript))
 204                 (diff t1 t2))
 205                (else
 206                  (cons (car t1) (map merge-versions (cdr t1) (cdr t2))))))
 207         (else (diff t1 t2))))
 208
 209 (tm-define (compare-file old)
 210   (let* ((t1 (tree-load-inclusion old))
 211          (t2 (buffer-tree))
 212          (u1 (tree->stree t1))
 213          (u2 (tree->stree t2))
 214          (x1 (if (tm-is? u1 'with) (cAr u1) u1))
 215          (mv (merge-versions x1 u2))
 216          (rt (stree->tree mv)))
 217     ;;(display* "merged= " (tree-simplify rt) "\n")
 218     (tree-set (buffer-tree) (tree-simplify rt))
 219     (version-first-difference)))