#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do function-tree)' -s $0 "$@" # -*- scheme -*-
!#
;;; function-tree --- display source as a tree

;; Copyright (C) 2002, 2007, 2009, 2010, 2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version.  There is NO WARRANTY.  See file COPYING for details.

;;; Commentary:

;; Usage: function-tree filename [--root]
;; Display two of the top-level forms in FILENAME as trees.
;; Optional arg ‘--root’ means display on
;; the root window instead of in a new one.

;;; Code:

(define-module (ttn-do function-tree)
  #:export (main)
  #:use-module ((ttn-do zzz banalities) #:select (check-hv
                                                  qop<-args))
  #:use-module ((ttn-do zzz personally) #:select (accumulator
                                                  whatever
                                                  FE))
  #:use-module ((ttn-do zzz x-protocol) #:select ((-x . zx-x)))
  #:use-module ((ttn-do zzz x-umbrages) #:select (n<-window-class
                                                  n<-event-mask
                                                  connection
                                                  set-icccm-properties!
                                                  drawing
                                                  press-ESC-to-quit!))
  #:use-module ((ttn-do mogrify) #:select (find-file-read-only
                                           editing-buffer)))

(define (list<- ls)
  (let ((acc (accumulator)))
    (let loop ((x ls))
      (cond ((null? x))
            ((pair? x) (acc (car x)) (loop (cdr x)))
            (else (acc x))))
    (acc)))

(define (layout tree)
  (let* ((max-level 0)
         (root (vector 0 #f #f #f 0 #f #f))
         (serial 1)
         (fast (make-hash-table))
         (flat (accumulator)))

    (define (tag! parent tree idx tot)
      (let* ((key (let ((rv serial))
                    (set! serial (1+ serial))
                    rv))
             (ptag (hash-ref fast parent))
             (level (1+ (vector-ref ptag 0)))
             (tag (vector level         ; 0
                          idx           ; 1
                          tot           ; 2
                          ptag          ; 3
                          #f            ; 4: polar coord
                          #f            ; 5: realized-x
                          #f            ; 6: realized-y
                          0)))          ; 7: da (angular velocity)
        (set! max-level (max max-level level))
        (flat tag)
        (hash-set! fast key tag)
        (and (pair? tree)
             (let* ((ls (list<- tree))
                    (count (length ls)))
               (FE ls (iota count) (lambda (x n)
                                     (tag! key x n count)))))))

    (hash-set! fast 0 root)
    (flat root)
    (tag! 0 tree 0 1)
    (set! flat (flat))
    (values max-level
            (stable-sort flat
                         (lambda (a b)
                           (< (vector-ref a 0)
                              (vector-ref b 0)))))))

(define pi (* 2 (asin 1)))

(define FORE-PIXEL #x000040)
(define BACK-PIXEL 0)

(define (select-random-tree filename)
  (editing-buffer (find-file-read-only filename)
    (let ((starts (accumulator)))
      (while (search-forward "\n(" #f #t)
        (starts (1- (point))))
      (let ((b (list-ref (starts) (random (length (starts))))))
        (goto-char b)
        (let ((rv (read (buffer-port))))
          (write-to-port (current-output-port) b (1+ (point)))
          rv)))))

(define (rect x y w h) (vector x y w h))
(define (rect-x r) (vector-ref r 0))
(define (rect-y r) (vector-ref r 1))
(define (rect-w r) (vector-ref r 2))
(define (rect-h r) (vector-ref r 3))

(define SETUP #f)
(define DMGR #f)
(define SCREEN-W #f)
(define SCREEN-H #f)
(define ROOT-WID #f)
(define GEOM #f)
(define WID #f)
(define VISUAL #f)

(define (set-GEOM/WID/VISUAL! q root?)
  (set! GEOM (let ((scale (if root? 1 3/4)))
               (cons (inexact->exact (* scale SCREEN-W))
                     (inexact->exact (* scale SCREEN-H)))))
  (set! WID (if root?
                ROOT-WID
                (DMGR
                 #:create-window
                 #:parent ROOT-WID #:class (n<-window-class
                                            'InputOutput)
                 #:width (car GEOM) #:height (cdr GEOM)
                 #:value-list (list 'BackPixel BACK-PIXEL
                                    'EventMask (n<-event-mask
                                                'KeyPress)))))
  (let* ((root 0)                       ; FIXME
         (vid (zx-x 'visual (q 'GetWindowAttributes
                               #:window WID)))
         (dv (zx-x `(roots ,root allowed-depths) SETUP))
         (found #f))
    (do ((d-idx 0 (1+ d-idx)))
        (found)
      (let ((count (zx-x `(,d-idx visuals-len) dv))
            (visuals (zx-x `(,d-idx visuals) dv)))
        (do ((v-idx 0 (1+ v-idx)))
            ((or found (= v-idx count)))
          (and (= vid (zx-x `(,v-idx visual-id) visuals))
               (set! found `(,(assq 'depth (zx-x d-idx dv))
                             ,@(zx-x v-idx visuals)))))))
    (set! VISUAL found)))

(define BPID #f)
(define BP-CLEAR-GC #f)

(define (details max-level sorted)
  (let* ((levels (iota (1+ max-level)))
         (acc (list->vector
               (map (lambda ignored
                      (accumulator))
                    levels))))
    (FE sorted (lambda (v)
                 ((vector-ref acc (vector-ref v 0)) v)))
    (array-map! acc (lambda (a)
                      (list->vector (a)))
                acc)
    (values levels
            (list->vector
             (map (lambda (n)
                    (DMGR #:create-gc BPID `(Foreground
                                             ,(+ FORE-PIXEL (* 12 n))
                                             Background
                                             ,BACK-PIXEL
                                             LineWidth
                                             ,n)))
                  levels))
            (let ((lev (make-vector (vector-length acc))))
              (array-index-map!
               lev (lambda (i)
                     (make-vector (vector-length (vector-ref acc i)))))
              (lambda (i)
                (array-map!
                 (vector-ref lev i)
                 (lambda (v)
                   (let ((par-v (vector-ref v 3)))
                     (list #:x1 (vector-ref par-v 5)
                           #:y1 (vector-ref par-v 6)
                           #:x2 (vector-ref v 5)
                           #:y2 (vector-ref v 6))))
                 (vector-ref acc i))
                (vector-ref lev i))))))

(define (limits bb)
  (or (and (< 50 (rect-w bb))
           (< 50 (rect-h bb)))
      (error "bb too small"))
  (let ((x (rect-x bb))
        (y (rect-y bb))
        (w (rect-w bb))
        (h (rect-h bb)))
    (values (+ x 25)
            (+ x (- w 25))
            (+ y 25)
            (+ y (- h 25))
            (* (1+ (random (min 9 (1+ (quotient w 100)))))
               (if (zero? (random 2)) 1 -1))
            (* (1+ (random (min 9 (1+ (quotient h 100)))))
               (if (zero? (random 2)) 1 -1))
            (inexact->exact (* 0.75 (min w h))))))

(define (dance io bb tree)
  (let ((max-level (whatever))
        (sorted (whatever))
        (xmin (whatever))
        (xmax (whatever))
        (ymin (whatever))
        (ymax (whatever))
        (dx (whatever))
        (dy (whatever))
        (amp (whatever))
        (levels (whatever))
        (contexts (whatever))
        (edges (whatever)))

    (define (place! v)
      (let* ((level  (vector-ref v 0))
             (idx    (vector-ref v 1))
             (tot    (vector-ref v 2))
             (par-v  (vector-ref v 3))
             (px     (vector-ref par-v 5))
             (py     (vector-ref par-v 6))
             (arrow  (make-polar (if (= 1 level)
                                     0
                                     (* amp (expt 0.6 level)))
                                 (+ (angle (vector-ref par-v 4))
                                    (- (random (/ pi 21)) (/ pi 10))
                                    (/ (* 2 pi idx)
                                       tot)))))
        (vector-set! v 4 arrow)
        (vector-set! v 5 (+ px (inexact->exact (real-part arrow))))
        (vector-set! v 6 (+ py (inexact->exact (imag-part arrow))))
        (vector-set! v 7 (/ (* pi (- (random 15) 7)) 180))))

    (define (draw-edges! i)
      (or (< max-level i)
          (io 'PolySegment
              #:drawable BPID
              #:gc (vector-ref contexts i)
              #:segments (edges i))))

    (define (update-position! v)
      (let* ((par-v (vector-ref v 3))
             (px (vector-ref par-v 5))
             (py (vector-ref par-v 6))
             (arrow (vector-ref v 4))
             (m (magnitude arrow))
             (a (angle arrow))
             (new (make-polar m (+ a (vector-ref v 7)))))
        (vector-set! v 4 new)
        (vector-set! v 5 (+ px (inexact->exact (real-part new))))
        (vector-set! v 6 (+ py (inexact->exact (imag-part new))))))

    (define (update-origin!)
      (let ((origin (car sorted)))
        (vector-set! origin 5 (+ (vector-ref origin 5) dx))
        (or (< xmin (vector-ref origin 5) xmax) (set! dx (- dx)))
        (vector-set! origin 6 (+ (vector-ref origin 6) dy))
        (or (< ymin (vector-ref origin 6) ymax) (set! dy (- dy)))))

    (define (move!)
      (update-origin!)
      (FE (cdr sorted) update-position!))

    ;; These next three call-with-values calls are to kludge around broken
    ;; ‘let*-values’ in Guile 1.4.x, most likely due to buggy syncase.  Ugh.
    (call-with-values (lambda () (layout tree))
      (lambda (a b)
        (set! max-level a)
        (set! sorted b)))
    (call-with-values (lambda () (limits bb))
      (lambda (a b c d e f g)
        (set! xmin a)
        (set! xmax b)
        (set! ymin c)
        (set! ymax d)
        (set! dx e)
        (set! dy f)
        (set! amp g)))
    (call-with-values (lambda () (details max-level (cdr sorted)))
      (lambda (a b c)
        (set! levels a)
        (set! contexts b)
        (set! edges c)))

    (let ((root (car sorted)))
      (vector-set! root 5 (+ (rect-x bb) (ash (rect-w bb) -1)))
      (vector-set! root 6 (+ (rect-y bb) (ash (rect-h bb) -1))))
    (FE (cdr sorted) place!)
    ;; rv
    (cons max-level
          (lambda (spin)
            (if (number? spin) (draw-edges! spin) (move!))))))

(define (do-it! root? filename)
  (set! *random-state* (seed->random-state (current-time)))
  (let* ((conn (connection))
         (q (conn #:q))
         (io (conn #:io))
         (dmgr (drawing conn)))
    (press-ESC-to-quit! conn)
    (set! SETUP (conn #:setup))         ; ugh
    (set! DMGR dmgr)                    ; double ugh
    (set! SCREEN-W (dmgr #:screen-w))
    (set! SCREEN-H (dmgr #:screen-h))
    (set! ROOT-WID (dmgr #:root-wid))
    (set-GEOM/WID/VISUAL! q root?)
    (set-icccm-properties!
     conn WID
     'WM_NAME "function-tree"
     'WM_ICON_NAME "function-tree"
     'WM_NORMAL_HINTS (list 'max-size GEOM))
    (q 'MapWindow #:window WID)
    ;; fixme: should be done in a ConfigureNotify handler
    (let ((alist (q 'GetGeometry #:drawable WID)))
      (set! GEOM (cons (zx-x 'width alist)
                       (zx-x 'height alist)))
      (set! BPID (dmgr
                  #:create-pixmap
                  #:width (car GEOM) #:height (cdr GEOM)
                  #:drawable WID #:depth (zx-x 'depth VISUAL)))
      (set! BP-CLEAR-GC (dmgr #:create-gc BPID `(Foreground
                                                 ,BACK-PIXEL
                                                 Background
                                                 ,BACK-PIXEL)))
      (q 'ChangeWindowAttributes
         #:window WID
         #:value-list (list 'BackPixmap BPID)))
    (let* ((mid (ash (car GEOM) -1))
           (one-where (rect 0 0 mid (cdr GEOM)))
           (one-full (dance io one-where (select-random-tree filename)))
           (one (cdr one-full))
           (two-where (rect mid 0 (- (car GEOM) mid) (cdr GEOM)))
           (two-full (dance io two-where (select-random-tree filename)))
           (two (cdr two-full))
           (overall-max-level (apply max (map car (list one-full two-full)))))
      (define (draw!)
        (q 'PolyFillRectangle
           #:drawable BPID
           #:gc BP-CLEAR-GC
           #:rectangles (vector
                         (list #:x 0 #:y 0
                               #:width (car GEOM)
                               #:height (cdr GEOM))))
        (do ((i 1 (1+ i)))
            ((< overall-max-level i))
          (one i)
          (two i))
        (q 'ClearArea #:window WID))
      (define (move!)
        (one #f)
        (two #f))

      (draw!)
      (let loop ((n 0))
        (move!)
        (io #:gobble!)
        (draw!)
        (loop (1+ n))))

    (conn #:bye)))

(define (main args)
  (check-hv args '((package . "ttn-do")
                   (version . "1.1")
                   (help . commentary)))
  (let ((qop (qop<-args args '((root)))))
    (do-it! (qop 'root) (car (qop '())))))

;;; function-tree ends here