#! $HOME/scheme/scm \ %0 %1 %2 %3 %4 %5 %6 %7 %8 %9
- !#
;;;;"hitch" HIghlighT Changed Hypertext red.
;;; Copyright 1998-1999 Aubrey Jaffer
;;; See the file "COPYING" for terms applying to this program.

(define (go-script)
  (cond ((not *script*))
	((= 3 (- (length *argv*) *optind*))
	 (apply hitch (list-tail *argv* *optind*)))
	(else
	 (display "\
\
Usage: hitch old.html new.html dest
\
  Writes DEST with a copy of NEW.HTML in which lines which differ
  (ignoring whitespace) between OLD.HTML and NEW.HTML are marked by
  turning the text foreground color red.

  OLD.HTML, NEW.HTML, and DEST may contain GLOB wildcards, in which
  case all the files matching NEW.HTML are copied.  If DEST contains
  wildcard characters, then it is taken as a pattern for the copied
  files; otherwise it is taken as a directory name.

  HITCH compares concatenated copies of these files; boundary movement
  will not foil the comparison.

http://swissnet.ai.mit.edu/~jaffer/infobar/index.html
"
		  (current-error-port))
	 (exit #f))))

(require 'sort)
(require 'scanf)
(require 'line-i/o)
(require 'net-clients)
(require 'string-search)
(require 'chapter-order)
(require 'i/o-extensions)

(define (split-pathname path)
  (let ((len (string-length path))
	(idx (or (string-reverse-index path #\/)
		 (string-reverse-index path #\\))))
    (if (and idx (< idx len))
	(list (substring path 0 (+ 1 idx))
	      (substring path (+ 1 idx) len))
	(list "./" path))))

(define (strip-markups dest dir . glob)
  (define splits '())
  (apply directory-for-each
	 (lambda (fname) (set! splits (cons fname splits)))
	 dir
	 glob)
  (set! splits (sort! splits chap:string<?))
  (call-with-output-file dest
    (lambda (oport)
      (map (lambda (fname)
	     (call-with-input-file (string-append dir fname)
	       (lambda (iport)
		 (do ((line (read-line iport) (read-line iport))
		      (linum 1 (+ 1 linum)))
		     ((eof-object? line) fname)	; (list fname linum)
		   (do ((idx (string-index line #\<)  (string-index line #\<)))
		       ((not idx) (write-line line oport))
		     (display (substring line 0 idx) oport)
		     (do ((lne (substring line idx (string-length line))
			       (read-line iport))
			  (lnum linum (+ 1 lnum)))
			 ((or (eof-object? lne) (string-index lne #\>))
			  (if (string-index lne #\>)
			      (let ((len (string-length lne))
				    (idx (string-index lne #\>)))
				(set! line (substring lne (+ idx 1) len))
				(set! linum lnum))))
		       (newline oport)))))))
	   splits))))

(define splits '())
(define changes '())
(define total-lines 1)

(define (slurp-diff diffname)
  (define changes '())
  (call-with-input-file diffname
    (lambda (port)
      (do ((line (read-line port) (read-line port)))
	  ((eof-object? line))
	(case (string-ref line 0)
	  ((#\< #\> #\-) #f)
	  ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
	   (let ((typ #f) (slin #f) (elin #f))
	     (sscanf line "%*d,%*d%[acd]%d,%d" typ slin elin)
	     (if (not typ) (sscanf line "%*d%[acd]%d,%d" typ slin elin))
	     (if (not slin) (slib:error 'funny line))
	     (set! changes
		   (cons (if elin (list slin elin) slin)
			 changes))))))))
  (reverse changes))

(define (string-whitespace? str)
  (do ((idx (+ -1 (string-length str)) (+ -1 idx)))
      ((or (negative? idx) (not (char-whitespace? (string-ref str idx))))
       (negative? idx))))

(define (advertise oport)
  (for-each
   (lambda (str) (display str oport))
   '("<P> <FONT COLOR=red> Lines changed since last version are marked "
     "in red</FONT> by <A HREF="
     "\"http://swissnet.ai.mit.edu/~jaffer/infobar/index.html\""
     ">HITCH</A>.</P>"))
  (newline oport))

(define (colorize newdir splits changes dstdir globber)
  (define change (car changes))
  (define (bump-changes)
    (cond ((null? (cdr changes)) (set! change 0))
	  (else (set! changes (cdr changes))
		(set! change (car changes))
		(if (list? change) (set! change (car change))))))
  (define (update-changes linum)
    (cond ((> linum change) (bump-changes))
	  ((not (= linum change)))
	  ((number? (car changes)) (bump-changes))
	  ((< linum (cadar changes)) (set! change (+ 1 change)))
	  (else (bump-changes))))
  (if (list? change) (set! change (car change)))
  (for-each
   (lambda (fname)
     (call-with-input-file (string-append newdir fname)
       (lambda (iport)
	 (call-with-output-file (string-append dstdir (globber fname))
	   (lambda (oport)
	     (define unadvertised? #t)
	     (define marked? #f)
	     (define mark? #f)
	     (define disp-text
	       (lambda (str oport)
		 (cond ((string-whitespace? str)
			(display str oport))
		       (mark? (display "<FONT COLOR=red>" oport)
			      (display str oport)
			      (display "</FONT>" oport))
		       (else  (display str oport)))))
	     (do ((line (read-line iport) (read-line iport))
		  (linum total-lines (+ 1 linum)))
		 ((eof-object? line)	; (update-changes linum)
		  (set! total-lines linum))
	       (set! mark? (= linum change))
	       (if mark? (set! marked? #t))
	       (cond
		((and unadvertised? marked? (string=? "</BODY>" line))
		 (advertise oport)
		 (set! unadvertised? #f)))
	       (do ((idx (string-index line #\<) (string-index line #\<)))
		   ((not idx) (disp-text line oport) (newline oport))
		 (disp-text (substring line 0 idx) oport)
		 (do ((lne (substring line idx (string-length line))
			   (read-line iport))
		      (lnum linum (+ 1 lnum)))
		     ((or (eof-object? lne) (string-index lne #\>))
		      (if (string-index lne #\>)
			  (let ((len (string-length lne))
				(idx (+ 1 (string-index lne #\>))))
			    (display (substring lne 0 idx) oport)
			    (set! line (substring lne idx len))
			    (set! linum lnum)
			    (set! mark? (= linum change)))))
		   (write-line lne oport)
		   (update-changes lnum)))
	       (update-changes linum)))))))
   splits))

(define (hitch oldhtml newhtml dsthtml)
  (set! total-lines 1)
  (call-with-tmpnam
   (lambda (oldtmp newtmp diffname)
     ;;(set! oldtmp "tmp-old.txt")
     ;;(set! newtmp "tmp-new.txt")
     ;;(set! diffname "tmp.diff")
     (let ((olddir (split-pathname oldhtml))
	   (newdir (split-pathname newhtml))
	   (dstdir (if (glob-pattern? dsthtml)
		       (split-pathname dsthtml)
		       (list dsthtml #f))))
       (let ((oldglob (cadr olddir))
	     (newglob (cadr newdir))
	     (dstglob (cadr dstdir)))
	 (set! olddir (car olddir))
	 (set! newdir (car newdir))
	 (set! dstdir (car dstdir))
	 (strip-markups oldtmp olddir oldglob)
	 (set! splits (strip-markups newtmp newdir newglob))
	 (system (string-append "diff -wB " oldtmp " " newtmp ">" diffname))
	 (set! changes (slurp-diff diffname))
	 (cond ((null? changes) (slib:error 'no-changes?)))
	 (colorize newdir splits changes dstdir
		   (if dstglob
		       (filename:substitute?? newglob dstglob)
		       identity)))))
   3))

(go-script)

;;; Local Variables:
;;; mode:scheme
;;; End: