(require 'posix-time)
(yreq "Utilities/yenta-utils")

;;;; Generic utilities.

;;;; Converting between various printed representations and binary.

(define (hexdigit i)
  (cond ((> i 15) #f)
	((> i 9) (integer->char (+ i (char->integer #\a) -10)))
	((>= i 0) (integer->char (+ i (char->integer #\0))))
	(else #f)))

;;; %%% I'll bet this is obsolete now. --- Foner.
(define (hex-digit? char)
  (or (and (char<=? #\0 char)
	   (char>=? #\9 char))
      (and (char<=? #\a char)
	   (char>=? #\f char))
      (and (char<=? #\A char)
	   (char>=? #\F char))))

;;; %%% I'll bet this is obsolete now. --- Foner.
(define (hex-digit-or-whitespace? char)
  (or (hex-digit? char)
      (char=? char #\Space)
      (char=? char #\Tab)
      (char=? char #\Newline)))

(define *inverse-hex-digits-plus-whitespace* (regcomp "[^0-9A-Fa-f \t\n]"))
(define (hex-string? str)
  (and (string? str)
       (not (equal? str ""))		; We don't consider the null string to be a hex string.
       (not (regsearch *inverse-hex-digits-plus-whitespace* str))))

(define (base64-string? str)
  (let ((s (remove-whitespace str)))
    (and (string? s)
	 (base64-decode s))))		; If it's got invalid syntax, this will return #f.

(define (ui:hex->bytes str)
  (let ((s (remove-whitespace str)))
    (let ((ret (make-string (div (string-length s) 2))))
      (do ((i 0 (+ i 2)))
	  ((= i (string-length s)) ret)
	(string-set! ret (div i 2)
		     (integer->char 
		      (+ (* 16 (hex-digit->integer (string-ref s i)))
			 (hex-digit->integer (string-ref s (+ i 1))))))))))

(define (ui:bytes->hex string)
  (let ((ret (make-string (* 2 (string-length string)))))
    (do ((i 0 (+ i 1)))
	((= i (string-length string)) ret)
      (string-set! ret (* i 2) 
		   (hexdigit (div (char->integer 
				   (string-ref string i)) 16)))
      (string-set! ret (+ 1 (* i 2))
		   (hexdigit (mod (char->integer 
				   (string-ref string i)) 16))))))

;;; The order of the clauses in the OR below is critical!  Some hex-strings are perfectly valid base64-strings, so we must -not-
;;; check if base64 first.  (Basically, any hex string with the right number of digits such that it shouldn't end with an equal
;;; sign; as it turns out, (ui:bytes->hex *local-yenta-id*) is such a string.  On the other hand, the chances of a base64 string
;;; looking like a hex string are very low if the string is long enough---since each base64 character encodes 6 bits, but each
;;; hex character encodes only 4 bits, the chances of a hex string looking like a base64 string are n^(1/4), where n is the length
;;; of the string---and that's -before- taking into account that there's a 2/3 chance that the string will end with an equal sign,
;;; which forces the issue.  (If we were clever, we'd check that first, but hey, the C is very fast.)  So the real chance of a
;;; hex string looking like a base64 string is (* 1/3 (^ n 1/4)).  For a 40-hex-digit YID, this is therefore one-third of 2^80.
(define (ui:hex-or-base64->bytes str)	; Very forgiving version.  Slightly redundant on removal of whitespace vs the primitives; fix later.
  (let ((s (remove-whitespace str)))
    (or (and (hex-string? s)
	     (ui:hex->bytes s))
	(base64-string? s))))

;;; ++
(define *ui:bytes-spacing* 4)		; Reasonable values are selected from the set '(1 2 4 5 8 10 20 40), e.g., divisors of 40-hex-digit SHA-1.

;;; Like ui:bytes->hex, but puts a space in between every *ui:bytes->hex-spacing* bytes.
;;; Intended -only- for human consumption when presented in, e.g., HTML tables, which
;;; otherwise would have a 40-digit string stuffed into them and couldn't wrap right.
(define (ui:bytes->hex-space string)
  (ui:spaced-string (ui:bytes->hex string)))

(define (ui:spaced-string digits)
  (let* ((oldlen (string-length digits))
	 (newlen (+ oldlen (1- (/ oldlen *ui:bytes-spacing*))))
	 (spaced (make-string newlen #\Space)))
    (do ((src 0 (1+ src))
	 (dst 0 (1+ dst)))
	((= src oldlen))
      (string-set! spaced dst (string-ref digits src))
      (when (zero? (mod (1+ src) *ui:bytes-spacing*))
	(inc! dst)))
    spaced))
;;; --

;;;; Handling HTML forms.

(define (ui:remove-checked lst)
  (define (rem-check lst index)
    (cond ((null? lst) '())
	  ((ui:form-datum (string-append "item-" (number->string index)))
             (rem-check (cdr lst) (+ index 1)))
	  (else (cons (car lst) (rem-check (cdr lst) (+ index 1))))))
  (rem-check lst 0))

(define (ui:on-off value)
  (if value "checked" ""))

(define (ui:selected value)
  (if value "selected" ""))

(define (ui:list->textarea lst)
  (if (null? lst)
      '()
      (cons (car lst) (cons "\n" (ui:list->textarea (cdr lst))))))

(define (ui:list->textarea-string lst)
  (reduce string-append (ui:list->textarea lst)))

(define (ui:textarea->list str)
  (filter (lambda (x) (> (string-length x) 0))
	  (vector->list (string-split "\r\n" str))))

(define (ui:literal str)
  (string-edit
   "\n" "<br>"
   (ui:line-literal str)
   #t))

(define (ui:line-literal str)
  (string-edit 
   "<" "&lt;"
   (string-edit 
    ">" "&gt;"
    (string-edit "&" "&amp;" str #t)
    #t)
   #t))

(define (ui:value-literal str)
  (string-edit
   "\"" "&quot;"
   (ui:literal str)))

(define (ui:no-tags str)
  (string-edit "<[^>]*>" "" str #t))

(define ui:pretty-list 'set!-below)		; Turn a scheme list into a <ul> list, quoting HTML.
(define ui:pretty-ordered-list 'set!-below)	; As above, but <ol>.
(define ui:pretty-html-list 'set!-below)	; As above, but not quoting HTML.
(define ui:pretty-ordered-html-list 'set!-below); As above.
(define ui:pretty-html-exp-list 'set!-below) 	; As above, but each element is a list of parts for the same line item.

(let ()
  (define (pretty-list lst start-tag end-tag comb-proc)
    (flatten
     (cons start-tag
	   (append
	    (map (lambda (elt) (comb-proc "<li>" elt))
		 lst)
	    (list end-tag)))))
  (define (p-h-l lst)
    (if (null? lst)
	(list "<p>(none)</p>")
	(pretty-list lst "<ul>" "</ul>" list)))
  (define (p-l lst)
    (p-h-l (map ui:literal lst)))
  (define (p-o-h-l lst)
    (if (null? lst)
	(list "<p>(none)</p>")
	(pretty-list lst "<ol>" "</ol>")))
  (define (p-o-l lst)
    (p-o-h-l (map ui:literal lst)))
  (define (p-h-e-l lst) 
    (if (null? lst)
	(list "<p>(none)</p>")
	(pretty-list lst "<ul>" "</ul>" cons)))
  (set! ui:pretty-list p-l)
  (set! ui:pretty-html-list p-h-l)
  (set! ui:pretty-ordered-list p-o-l)
  (set! ui:pretty-ordered-html-list p-o-h-l)
  (set! ui:pretty-html-exp-list p-h-e-l)
)

(define (expand-dir str)
  (string-edit "~" (getenv "HOME") str))

;;;; Dealing with notification of new news.  [%%% are these still actually used?]

(define (ui:add-news-item URL section . headline)
  (set! *ui:news-new* #t)
  (set! headline (map (lambda (str) (string-append str " ")) headline))	; %%% ugh.  this will misformat certain ones.  *sigh*.  rework this idea.
  (set! *ui:news* (append! *ui:news* 
			   `((,URL ,section "[" ,(date-string) "] " . 
				   ,headline)))))

(define (ui:note-pic con close-proc)
  (cond (*ui:news-note*	; %%% Note that nothing ever sets this now.  We should clean this up somehow (and see use *ui:news-new* below).
	 (httpd:send-headers con 200
			     '("Content-Type" "image/gif")
			     `("Expires" ,(date-string)))
	 (display (cadddr (assoc "news-off.gif-" *ui-file-list*)) con)
	 (scheduler:when *ui:news-new*
	   (display (cadddr (assoc "news-on.gif-" *ui-file-list*)) con)
	   (close-proc))
	 #f)				; DON'T try to fetch a page from *ui-file-list*!  We just served one.
	(t
	 (if *ui:news-new*
	     "icon-news-open.gif"
	     "icon-news-closed.gif"))))

;;;; The scanning/clustering animation.

;;; This shows successive frames of the animation.  It always starts with the GIF preamble,
;;; assumed to be in -0, and then shows a different frame each time *ui:animate-scan/cluster-counter*
;;; changes.  When *ui:animate-scan/cluster-counter* becomes negative, it shows the final frame.
;;; *ui:animate-scan/cluster-counter* uses modulo arithmetic, so it's safe if it just counts;
;;; note that the frames will be shown out-of-order if you do anything but increment it.
;;;
;;; This currently assumes that the GIF preamble is in frame 0, that the cyclical content
;;; is in frames 1, 2, and 3, and that the final frame is called "done".
(defvar *ui:animate-scan/cluster-counter* 0) ; If this is negative, show the last frame.
(define (ui:animate-scan/cluster con close-proc)
  (define (show-frame i)
    (let ((filename (format nil "scanning-animation-~A.gif-" i))) ; Not ~D, and not ~S, 'cause it might be "done"!
;     (format-debug 0 "~&Showing frame ~A.~&" filename)
      (display (cadddr (assoc filename *ui-file-list*)) con)))
; (format-debug 0 "~%ui:animate-scan/cluster entry.~&")
  (httpd:send-headers con 200
		      '("Content-Type" "image/gif")
		      `("Expires" ,(date-string)))
  (show-frame 0)			; Emit the GIF preamble.
  ;; It's possible that this will be called, from the entry in *ui-pages*, via a browser reload.
  ;; After all, we explicitly declare, immediately above, that the image expires instantly.
  ;; This means that, if the user goes somewhere else in the UI, and then returns (via the
  ;; browser's Back button or a browser bookmark or whatever) to the page which had this
  ;; animation on it, the browser will refetch it, instead of using its cached copy.  We
  ;; must -not- allow that to kick off a brand-new animation, since we're presumably done
  ;; already.  So, if we think we're not actually animating, -don't start-.  Instead, just
  ;; show the "done" frame again.
  (cond (*ui:animation-enable*
;	 (format-debug 0 "~%ui:animate-scan/cluster in main animation branch.~&")
	 (ui:show-animation)		; Seeing the first frame depends on the fact that add-periodic-task! first runs the task -after- the period.
	 (let ((last-counter (1- *ui:animate-scan/cluster-counter*))) ; Make them unequal, so the first frame gets shown immediately.
	   (scheduler:remove-task! "Animation") ; Handle the case in which we're already running, and the user hits reload.
	   (scheduler:add-task!
	     "Animation" *httpd:priority*
	     (lambda ()
	       (not (= *ui:animate-scan/cluster-counter* last-counter)))
	     (lambda ()
	       (cond ((negative? *ui:animate-scan/cluster-counter*)
		      (show-frame "done") ; Emit the final frame, and the GIF postamble.
		      (close-proc)
		      (set! *ui:animate-scan/cluster-counter* 0)
		      (scheduler:remove-task! "Animation"))
		     (t
		      (let ((frame (1+ (mod *ui:animate-scan/cluster-counter* 3)))) ; 3 content frames.
;			(format-debug 100 "Showing frame ~S~&" frame)
			(show-frame frame)) ; Emit frame n.
		      (set! last-counter *ui:animate-scan/cluster-counter*)))))))
	(t				; We're here because of a browser reload, not the start of a new animation.
;	 (format-debug 0 "~%ui:animate-scan/cluster in reload branch.~&")
	 (scheduler:remove-task! "Animation reload") ; Just in case.
	 (scheduler:add-once-task!
	   "Animation reload" *httpd:priority* scheduler:always
	   (lambda ()
	     (show-frame "done")	; Emit the final frame, and the GIF postamble.
	     (close-proc)
	     (set! *ui:animate-scan/cluster-counter* 0)))))
  #f)					; DON'T try to fetch a page from *ui-file-list*!  We just served one.

(define ui:animation-height 200)	; Pixels.
(define ui:animation-width 200)		; Pixels.
(define (ui:animation-html)		; Returns the HTML fragment that we should hand to the browser to get it to start fetching the image.
  ;; %%% Not clear to me how the ALT ever goes away, 'cause browser isn't fetching anything if non-images...
  (format nil "<img src=\"scanning-animation.gif\" width=\"~A\" height=\"~A\" align=\"left\" ~
                    alt=\"[Scanning documents and building clusters of interests; please stand by...]\"~
               >"
	  ui:animation-width ui:animation-height))

;;; Requests successive frames be shown, every few seconds, until instructed to stop.
;;; Note that we might take up to a single frame period to notice the request to stop.
(define *ui:animation-period* 1)		; How many seconds between frames.
(defvar *ui:animation-enable* #f)		; Set to #t at the start.  To stop, someone else must set this #f again.
(define (ui:show-animation)
; (format-debug 0 "~%ui:show-animation entered; *ui:animation-enable* was ~S before entry.~&" *ui:animation-enable*)
  (set! *ui:animation-enable* #t)
  (scheduler:remove-task! "Animation control") ; Handle the case in which we're already running, and the user hits reload.
  (scheduler:add-periodic-task! 
    "Animation control" *httpd:priority* *ui:animation-period*
    (lambda ()
      (cond (*ui:animation-enable*
	     (inc! *ui:animate-scan/cluster-counter*))
	    (t
	     (set! *ui:animate-scan/cluster-counter* -1)
	     (scheduler:remove-task! "Animation control"))))))

;;;; Dead code.

;;; Here's what I -wanted- to write, but it can't be used, because it winds up returning
;;; #<unspecified>, and use-methods takes that as a valid name!
; (define (ui:animate-scan/cluster con close-proc)
;   (define (show-frame i)
;     (let ((filename (format nil "scanning-animation-~A.gif-" i))) ; Not ~D, and not ~S, 'cause it might be "done"!
;       (display (cadddr (assoc filename *ui-file-list*)) con)))
;   (httpd:send-headers con 200
; 		      '("Content-Type" "image/gif")
; 		      `("Expires" ,(date-string)))
;   (show-frame 0)			; Emit the GIF preamble.
;   (let ((last-counter *ui:animate-scan/cluster-counter*))
;     (scheduler:loop (not (negative? *ui:animate-scan/cluster-counter*))
;       (scheduler:when (not (= *ui:animate-scan/cluster-counter* last-counter))
; 	(let ((frame (1+ (mod *ui:animate-scan/cluster-counter* 3)))) ; 3 content frames.
; 	  (show-frame frame))		; Emit frame n.
; 	(set! last-counter *ui:animate-scan/cluster-counter*))
;       (show-frame "done")		; Emit the final frame, and the GIF postamble.
;       (close-proc)
;       (set! *ui:animate-scan/cluster-counter* 0))))

;;; End of file.
