;;; circle-frisk --- visualize frisk results

;;; Copyright (C) 2002, 2007 Thien-Thi Nguyen

;;; Commentary:

;; Usage: circle-frisk [root] [FILE ...]
;;
;; Show frisk results in a window.  Each line is an edge.
;; Internal modules are on the inner circle, and external the outer.
;; Optional first arg "root" means use the root window.  Modules move
;; about; info on currently active module is sent to stdout.

;;; Code:

(use-modules
 ((scripts frisk) #:select (make-frisker
                            mod-int?
                            mod-up-ls mod-down-ls
                            edge-up edge-down))
 ((ice-9 pretty-print) #:select (pretty-print))
 ((ttn-do zzz x-protocol) #:prefix xsb))

(define REPORT
  ((make-frisker) ((if (member "root" (command-line)) cddr cdr)
                   (command-line))))
(and (null? (REPORT #:modules))
     (error "no modules specified"))

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

(define CONN     (or (xsb-connect) (exit #f)))
(define SETUP    (vector-ref CONN 1))
(define ID-BASE  (xsb-x 'resource-id-base SETUP))
(define SCREEN   (xsb-x '(roots 0)        SETUP))
(define SCREEN-W (xsb-x 'width-in-pixels  SCREEN))
(define SCREEN-H (xsb-x 'height-in-pixels SCREEN))
(define ROOT-WID (xsb-x 'root             SCREEN))

(pretty-print SCREEN)

(define (id n)
  (+ ID-BASE n))

(define q (xsb-synchronous-request-proc CONN 'keyword-style))

(define %INPUT-OUTPUT 1)                ; sigh

(define create-gc
  (let ((serial #x2000))
    (lambda (wid plist)
      (let ((new-cid (return-it (id serial)
                       (set! serial (1+ serial)))))
        (q 'CreateGC
           #:drawable wid
           #:cid new-cid
           #:value-list plist)
        new-cid))))

(define (n<-gx symbol)                  ; fixme
  (assq-ref '((clear . 0)
              (and . 1)
              (andReverse . 2)
              (copy . 3)
              (andInverted . 4)
              (noop . 5)
              (xor . 6)
              (or . 7)
              (nor . 8)
              (equiv . 9)
              (invert . 10)
              (orReverse . 11)
              (copyInverted . 12)
              (orInverted . 13)
              (nand . 14)
              (set . 15))
            symbol))

(define FORE-PIXEL #xffff00)
(define BACK-PIXEL #xaa8855)

(define (fso s . args)
  (apply simple-format #t s args))

(set! *random-state* (seed->random-state (current-time)))

(let* ((modules (REPORT #:modules))
       (edges (REPORT #:edges))
       (count (length modules))
       (pos: (make-object-property))
       (x: (make-object-property))
       (y: (make-object-property))
       (r: (make-object-property))
       (m: (make-object-property))
       (root? (member "root" (command-line))) ; fixme
       (geometry (if root?
                     (cons SCREEN-W SCREEN-H)
                     (cons 800 600)))
       (wid (if root?
                ROOT-WID
                (let ((new-wid (id 42)))
                  (q 'CreateWindow
                     #:wid new-wid #:parent ROOT-WID #:class %INPUT-OUTPUT
                     #:width (car geometry) #:height (cdr geometry)
                     #:value-list (list 'BackPixel BACK-PIXEL
                                        'BorderPixel FORE-PIXEL))
                  new-wid)))
       (contexts (map (lambda (ent)
                        (cons (car ent) (create-gc wid (cdr ent))))
                      `((d Foreground ,FORE-PIXEL ;;; draw
                           Background ,BACK-PIXEL)
                        (e Foreground ,BACK-PIXEL ;;; erase
                           Background ,FORE-PIXEL)
                        (x Function   ,(n<-gx 'xor) ;;; xor
                           Foreground ,FORE-PIXEL
                           Background ,BACK-PIXEL))))
       (center-x (ash (car geometry) -1))
       (center-y (ash (cdr geometry) -1))
       (xmin 25) (xmax (- (car geometry) 25))
       (ymin 25) (ymax (- (cdr geometry) 25))
       (dx (if (zero? (random 2)) 1 -1))
       (dy (if (zero? (random 2)) 1 -1)))

  (define (random-module)
    (list-ref modules (random count)))

  (define (clear)
    (q 'ClearArea
       #:window wid))

  (define (draw-edges! gc-name . ls)
    (q 'PolySegment
       #:drawable wid
       #:gc (assq-ref contexts gc-name)
       #:segments (list->vector
                   (map (lambda (edge)
                          (let ((u-mod (edge-up   edge))
                                (d-mod (edge-down edge)))
                            (list #:x1 (x: u-mod)
                                  #:y1 (y: u-mod)
                                  #:x2 (x: d-mod)
                                  #:y2 (y: d-mod))))
                        (if (null? ls)
                            edges
                            (car ls))))))

  (define (new-pos! module r a)
    (let ((pos (make-polar r a)))
      (set! (pos: module) pos)
      (set! (x: module) (+ center-x (inexact->exact (real-part pos))))
      (set! (y: module) (+ center-y (inexact->exact (imag-part pos))))))

  (define (random-mult! module)
    (set! (m: module) (if (mod-int? module)
                          (- (random 29.0) 14.0)
                          (- (random  5.0)  2.0))))

  (clear)
  (or root? (q 'MapWindow #:window wid))
  (fso "~A modules (~A edges)\n" count (length edges))
  (let ((max-r (min center-x center-y)))
    (for-each (lambda (module)
                (let ((r (* max-r
                            (cond ((equal? '(guile-user) module) 0.05)
                                  ((not (mod-int? module)) 1)
                                  (else
                                   (min 1.0
                                        (+ 0.3 (/ (length (mod-up-ls module))
                                                  count))))))))
                  (set! (r: module) r)
                  (new-pos! module r (/ pi 2)))
                (random-mult! module))
              modules))
  (let loop ()
    (let ((mult (map (lambda (module)
                       (if (zero? (random 5))
                           (random-mult! module)
                           (m: module)))
                     modules)))
      (draw-edges! 'x)
      (do ((i 0 (1+ i)))
          ((= i 100))
        ;;(draw-edges! 'e)
        (set! center-x (+ center-x dx))
        (or (< xmin center-x xmax) (set! dx (- dx)))
        (set! center-y (+ center-y dy))
        (or (< ymin center-y ymax) (set! dy (- dy)))
        (for-each (lambda (module mult)
                    (new-pos! module (r: module) (+ (angle (pos: module))
                                                    (* mult (/ pi 4 100)))))
                  modules
                  mult)
        (draw-edges! 'x)
        (usleep 10000)))
    ;;(clear)
    (draw-edges! 'd)
    (or root? (usleep 250000))
    (draw-edges! 'e)
    (loop))
  (clear))

;;; circle-frisk ends here