* programs using (ttn-do zzz x-protocol)
@ 2007-11-21 14:35 Thien-Thi Nguyen
0 siblings, 0 replies; only message in thread
From: Thien-Thi Nguyen @ 2007-11-21 14:35 UTC (permalink / raw)
To: guile-sources; +Cc: guile-user
[-- Attachment #1: Type: text/plain, Size: 448 bytes --]
greetings earthlings,
please find attached three small programs that use newly
released module `(ttn-do zzz x-protocol)', available at
<http://www.gnuvola.org/software/ttn-do/>.
old-timers may remember circle-frisk from guile-xlib dayz,
but let's let the dead lie in peace.
i think i'll use these as a vehicle to play w/ git.
idea is to prepare ourselves for the frenzy of hacking
that will go into SORP: {son-of,scheme-only}-rat-poison!
thi
[-- Attachment #2: xlsatoms --]
[-- Type: text/plain, Size: 471 bytes --]
;;; xlsatoms
;;; Copyright (C) 2007 Thien-Thi Nguyen
(use-modules
((ttn-do zzz x-protocol) #:prefix xsb))
(define CONN (or (xsb-connect) (exit #f)))
(define q (xsb-synchronous-request-proc CONN))
(let loop ((atom 1))
(let ((a (q 'GetAtomName `((atom . ,atom)))))
(or (eqv? atom (assq-ref a 'bad-value))
(begin (simple-format #t "~A\t~A\n" atom (xsb-x 'name a))
(loop (1+ atom))))))
(exit (xsb-disconnect CONN))
;;; xlsatoms ends here
[-- Attachment #3: xprop --]
[-- Type: text/plain, Size: 2377 bytes --]
;;; xprop
;;; Copyright (C) 2007 Thien-Thi Nguyen
(use-modules
((ice-9 pretty-print) #:select (pretty-print))
((srfi srfi-13) #:select (string-join))
((ttn-do zzz x-protocol) #:prefix xsb))
(define CONN (or (xsb-connect) (exit #f)))
(define ROOT-WINDOW-ID (xsb-x '(roots 0 root) (vector-ref CONN 1)))
(define q (xsb-synchronous-request-proc CONN 'plist-input))
(define ROOTW-PROPERTY-ATOMS
(xsb-x 'atoms (q 'ListProperties `(window ,ROOT-WINDOW-ID))))
(define ROOTW-PROPERTY-NAMES
(map (lambda (atom)
(xsb-x 'name (q 'GetAtomName `(atom ,atom))))
ROOTW-PROPERTY-ATOMS))
(define -TYPES '((4 . ATOM)
(6 . CARDINAL)
(19 . INTEGER)
(31 . STRING)
(33 . WINDOW)))
(define (fs s . args)
(apply simple-format #f s args))
(define (hexs n)
(fs "#x~A" (number->string n 16)))
(define (atom-name atom)
(xsb-x 'name (q 'GetAtomName `(atom ,atom))))
(for-each (lambda (atom name)
(define (get . rest)
(q 'GetProperty `(window
,ROOT-WINDOW-ID
property
,atom
,@rest)))
(let* ((a (get))
(type (xsb-x 'type a))
(known (assq-ref -TYPES type))
(pretty (and known (fs " (~A)" known)))
(after (xsb-x 'bytes-after a)))
(define (get-again proc)
(string-join
(map proc (xsb-x 'value (get 'type type
'long-length after)))
", " 'infix))
(write-line
(fs "property[~A]: ~A~A" atom name
(case (or known type)
((ATOM)
(fs "~A = ~A" pretty (get-again atom-name)))
((CARDINAL INTEGER)
(fs "~A = ~A" pretty (get-again number->string)))
((STRING)
(fs "~A = ~S" pretty (get-again identity)))
((WINDOW)
(fs "~A: window id # ~A" pretty (get-again hexs)))
(else
" ???"))))))
ROOTW-PROPERTY-ATOMS
ROOTW-PROPERTY-NAMES)
(exit (xsb-disconnect CONN))
;;; xprop ends here
[-- Attachment #4: circle-frisk --]
[-- Type: text/plain, Size: 6831 bytes --]
;;; 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
[-- Attachment #5: Type: text/plain, Size: 140 bytes --]
_______________________________________________
Guile-user mailing list
Guile-user@gnu.org
http://lists.gnu.org/mailman/listinfo/guile-user
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2007-11-21 14:35 UTC | newest]
Thread overview: (only message) (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2007-11-21 14:35 programs using (ttn-do zzz x-protocol) Thien-Thi Nguyen
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).