#! /usr/local/bin/scm \ %0 %1 %2 %3 %4 %5 %6 %7 %8 %9 - !# ;;;;"hitch" HIghlighT Changed Hypertext red. ;;; Copyright 1998, 1999, 2002 Aubrey Jaffer ;; ;; 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 2 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, write to the Free Software ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (require 'sort) (require 'array) (require 'array-for-each) (require 'directory) (require 'transact) (require 'string-search) (require 'chapter-order) (require 'html-for-each) (require 'diff) (require-if 'compiling 'charplot) (require-if 'compiling 'printf) (define (hitch.script args) (cond ((= 3 (length args)) (apply hitch args)) ((and (= 4 (length args)) (eqv? 0 (substring? "-c" (car args))) (do-context-arg (substring (car args) 2 (string-length (car args))))) (apply hitch (cdr args))) ((and (= 5 (length args)) (equal? "-c" (car args)) (do-context-arg (cadr args))) (apply hitch (cddr args))) (else (hitch.usage)))) (define (hitch.usage) (display "\ \ Usage: hitch [-c [NUM]] old.html new.html dest \ Writes DEST with a copy of NEW.HTML in which words which differ (ignoring whitespace) between OLD.HTML and NEW.HTML are marked by turning the text foreground color red. Optional argument -c colors NUM words around changes red also. If -c is given without NUM, the word context defaults to 3. OLD.HTML, NEW.HTML, and DEST may contain GLOB wildcards, in which case all the files matching NEW.HTML are copied. If DEST ends with '/', then it is taken as a directory name; the pattern for the files copied into DEST is taken from NEW.HTML. HITCH compares the word sequence from the concatenation of the OLD.HTML files with the word sequence from the concatenation of the NEW.HTML files; boundary movement will not foil the comparison. If there are no differences between OLD and NEW sets of files, then no DEST files are written and hitch returns a non-zero status. http://swiss.csail.mit.edu/~jaffer/infobar " (current-error-port)) #f) (define (capture-words dir splits) (let ((wcnt 0) (len 1000)) (define words (make-vector len #f)) (for-each (lambda (fname) (html-for-each (string-append dir fname) ;(print wcnt ) (lambda (str) (cond ((>= wcnt len) (set! len (+ len (quotient len 2))) (set! words (vector-set-length! words len)))) ;;(display str prt) (newline prt) (vector-set! words wcnt (string->symbol str)) (set! wcnt (+ 1 wcnt))) #f #f #f)) splits) (vector-set-length! words wcnt))) (define (do-context-arg str) (define num (string->number str)) (cond ((equal? "" str) (set! num 3))) (cond ((and (number? num) (integer? num) (not (negative? num))) (set! pre-context (quotient num 2)) (set! post-context (- num pre-context)) #t) (else #f))) (define pre-context 0) (define post-context 0) (define (edits2bitmap edits len-b) (define mods (make-array (A:bool #f) len-b)) (array-for-each (lambda (idx) (if (positive? idx) (array-set! mods #t (+ -1 idx)))) edits) mods) (define (colorize newdir splits dstdir globber changes) (define wcnt 0) (for-each (lambda (fname) (call-with-output-file (string-append dstdir (globber fname)) (lambda (oport) (define unadvertised? #t) (define in-head? #f) (define marking? #f) (define marked? #f) (define mark? #f) (html-for-each (string-append newdir fname) (lambda (word) ; word (set! mark? (array-ref changes wcnt)) (set! wcnt (+ 1 wcnt)) (cond ((and mark? (not marking?) (not in-head?)) (set! marking? #t) (set! marked? #t) (display "" oport)) ((and mark? marking? (not in-head?))) (marking? (set! marking? #f) (display "" oport))) (display word oport)) (lambda (tag) ; tag (define len (string-length tag)) (cond ((and marking? (not in-head?)) (set! marking? #f) (display "" oport))) (cond ((< len 6)) ((string-ci=? "
" oport))) (newline oport)))))) splits)) (define (advertise oport) (display "Words changed since last version are marked in red by HITCH.
" oport) (newline oport)) ;; Returns list: (directory/ glob-pattern) (define (split-pathname path) (let ((len (string-length path)) (idx (or (string-reverse-index path #\/) (string-reverse-index path #\\)))) (if idx (list (substring path 0 (+ 1 idx)) (and (not (= (+ 1 idx) len)) (substring path (+ 1 idx) len))) (list "./" path)))) (define (make-splits dir . glob) (define splits '()) (apply directory-for-each (lambda (fname) (set! splits (cons fname splits))) dir glob) (set! splits (sort! splits chap:string)) splits) (define (hitch oldhtml newhtml dsthtml) (set! compares 0) (set! tick 0) (let ((olddir (split-pathname oldhtml)) (newdir (split-pathname newhtml)) (dstdir (split-pathname dsthtml))) (let ((oldglob (cadr olddir)) (newglob (cadr newdir)) (dstglob (cadr dstdir))) (set! olddir (car olddir)) (set! newdir (car newdir)) (set! dstdir (car dstdir)) (let* ((old-splits (make-splits olddir oldglob)) (new-splits (make-splits newdir newglob)) (old-words (capture-words olddir old-splits)) (new-words (capture-words newdir new-splits))) (print 'diff:edits (vector-length old-words) (vector-length new-words)) (print 'length-time (time-call diff:edit-length old-words new-words) 'tick tick) (set! compares 0) (set! tick 0) (let ((edits #f ; (diff:edits old-words new-words) ) (edits-length #f)) (print 'edits-time (time-call (lambda () (set! edits (diff:edits old-words new-words))))) (set! edits-length (car (array-dimensions edits))) (print 'edits-length edits-length 'calls compares 'tick tick) (if (pair? splts) (write-histo "histo-2.dat" splts 50)) (cond ((zero? edits-length) (slib:warn 'no-changes?) #f) (else ;;; (print-edits edits edits-length old-words new-words) (print 'colorize dstdir (or dstglob newglob)) (colorize newdir new-splits dstdir (if dstglob (filename:substitute?? newglob dstglob) identity) (edits2bitmap edits (car (array-dimensions new-words)))) #t))))))) (defvar splts '()) (defvar compares 0) (defvar tick 0) (define i/ (cond ((provided? 'inexact) /) (else quotient))) (define (time-call proc . args) (let ((start-time (get-internal-run-time))) (apply proc args) (i/ (* 1000 (- (get-internal-run-time) start-time)) internal-time-units-per-second))) (define (write-histo file splits res) (require 'charplot) (require 'printf) (call-with-output-file file (lambda (port) (define bins (histobins splits res)) (for-each (lambda (bin) (apply fprintf port "%d %d\\n" bin)) bins)))) ;;; Local Variables: ;;; mode:scheme ;;; End: (if *script* (exit (hitch.script (list-tail *argv* *optind*))))