#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do circle-frisk)' -s $0 "$@" # -*- scheme -*-
!#
;;; circle-frisk --- visualize frisk results

;; Copyright (C) 2002, 2007, 2009, 2010 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: 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 arg `--root' means use the root window.  Modules move
;; about; info on currently active module is sent to stdout.

;;; Code:

(define-module (ttn-do circle-frisk)
  #:export ()
  #:use-module ((ttn-do zzz banalities) #:select (check-hv
                                                  qop<-args))
  #:use-module ((ttn-do zzz personally) #:select (FE fso fs))
  #:use-module ((ttn-do zzz x-umbrages) #:select (n<-window-class
                                                  n<-gx
                                                  n<-event-mask
                                                  connection
                                                  set-icccm-properties!
                                                  drawing
                                                  press-ESC-to-quit!))
  #:use-module ((scripts frisk) #:select (make-frisker
                                          mod-int?
                                          mod-up-ls
                                          edge-up edge-down)))

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

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

(define (circle-frisk root? filenames)
  (let* ((conn (connection))
         (q (conn #:q))
         (io (conn #:io))
         (dmgr (drawing conn))
         (r ((make-frisker) filenames)))
    (and (null? r) (error "no modules specified"))
    (set! *random-state* (seed->random-state (current-time)))
    (press-ESC-to-quit! conn)
    (let* ((modules (r #:modules))
           (edges (r #:edges))
           (count (length modules))
           (pos: (make-object-property))
           (x: (make-object-property))
           (y: (make-object-property))
           (r: (make-object-property))
           (m: (make-object-property))
           (geometry (if root?
                         (cons (dmgr #:screen-w) (dmgr #:screen-h))
                         (cons 800 600)))
           (root-wid (dmgr #:root-wid))
           (wid (if root?
                    root-wid
                    (dmgr
                     #:create-window
                     #:parent root-wid #:class (n<-window-class
                                                'InputOutput)
                     #:width (car geometry) #:height (cdr geometry)
                     #:value-list (list 'BackPixel BACK-PIXEL
                                        'BorderPixel BACK-PIXEL
                                        'EventMask (n<-event-mask
                                                    'KeyPress)))))
           (contexts (map (lambda (ent)
                            (cons (car ent) (dmgr #: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 (clear)
        (q 'ClearArea
           #:window wid))

      (define (draw-edges! gc-name . ls)
        (io '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))
      (set-icccm-properties!
       conn wid
       'WM_NAME (fs "circle-frisk (V~A E~A)" count (length edges))
       'WM_ICON_NAME "circle-frisk"
       'WM_NORMAL_HINTS (list 'max-size geometry))
      (let ((max-r (min center-x center-y)))
        (FE modules
            (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))))
      (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 42))
            (io #:gobble!)
            ;;(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)))
            (FE modules mult
                (lambda (module mult)
                  (new-pos! module (r: module) (+ (angle (pos: module))
                                                  (* mult (/ pi 4 100))))))
            (draw-edges! 'x)
            (io #:flush!)
            (usleep 10000)))
        (clear)
        (draw-edges! 'd)
        (io #:flush!)
        (or root? (usleep 250000))
        (draw-edges! 'e)
        (loop))
      (clear))
    (conn #:bye)))

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

;;; circle-frisk ends here