From mboxrd@z Thu Jan 1 00:00:00 1970 Path: main.gmane.org!not-for-mail From: Thien-Thi Nguyen Newsgroups: gmane.lisp.guile.user,gmane.lisp.guile.sources Subject: circle-frisk 0.20020909 Date: Sun, 08 Sep 2002 20:24:52 -0700 Sender: guile-user-admin@gnu.org Message-ID: Reply-To: ttn@glug.org NNTP-Posting-Host: localhost.gmane.org X-Trace: main.gmane.org 1031542331 4488 127.0.0.1 (9 Sep 2002 03:32:11 GMT) X-Complaints-To: usenet@main.gmane.org NNTP-Posting-Date: Mon, 9 Sep 2002 03:32:11 +0000 (UTC) Cc: guile-user@gnu.org Return-path: Original-Received: from monty-python.gnu.org ([199.232.76.173]) by main.gmane.org with esmtp (Exim 3.35 #1 (Debian)) id 17oFHV-0001AG-00 for ; Mon, 09 Sep 2002 05:32:09 +0200 Original-Received: from localhost ([127.0.0.1] helo=monty-python.gnu.org) by monty-python.gnu.org with esmtp (Exim 4.10) id 17oFHU-0000GR-00; Sun, 08 Sep 2002 23:32:08 -0400 Original-Received: from list by monty-python.gnu.org with tmda-scanned (Exim 4.10) id 17oFH7-0000D2-00 for guile-user@gnu.org; Sun, 08 Sep 2002 23:31:45 -0400 Original-Received: from mail by monty-python.gnu.org with spam-scanned (Exim 4.10) id 17oFH4-0000Bw-00 for guile-user@gnu.org; Sun, 08 Sep 2002 23:31:44 -0400 Original-Received: from ca-crlsca-cuda3-c6a-b-211.crlsca.adelphia.net ([68.71.15.211] helo=giblet) by monty-python.gnu.org with esmtp (Exim 4.10) id 17oFGx-00006W-00; Sun, 08 Sep 2002 23:31:35 -0400 Original-Received: from ttn by giblet with local (Exim 3.35 #1 (Debian)) id 17oFAS-00066O-00; Sun, 08 Sep 2002 20:24:52 -0700 Original-To: guile-sources@gnu.org Errors-To: guile-user-admin@gnu.org X-BeenThere: guile-user@gnu.org X-Mailman-Version: 2.0.11 Precedence: bulk List-Help: List-Post: List-Subscribe: , List-Id: General Guile related discussions List-Unsubscribe: , List-Archive: Xref: main.gmane.org gmane.lisp.guile.user:950 gmane.lisp.guile.sources:5 X-Report-Spam: http://spam.gmane.org/gmane.lisp.guile.user:950 well, here's the animated version. appreciated would be a patch to do proper xor instead of the cheesy erasing-gc. example usage (makes a nice screensaver): dir=`guile-tools --help | tail -1 | sed 's/.* //g'` circle-frisk root $dir/* happy hacking, thi _______________________________________________________________ #!/bin/sh exec guile-xlib -s $0 "$@" # -*- scheme -*- !# ;;; circle-frisk --- visualize frisk results ;;; Copyright (C) 2002 Thien-Thi Nguyen ;;; This program is part of xplay, released under GNU GPL v2 with ABSOLUTELY ;;; NO WARRANTY. See http://www.gnu.org/copyleft/gpl.txt for details. ;;; Version: 0.20020909 ;;; Commentary: ;; Usage: circle-frisk [root] [FILE ...] ;; ;; circle-frisk shows 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: (set! *random-state* (seed->random-state (current-time))) (define report #f) ; ugh (use-modules (scripts frisk)) (define (report! files) (set! report ((make-frisker) files))) (use-modules (xlib core) (xlib xlib) (local-utils)) (define put set-object-property!) (define get object-property) (define (vmac-exact! v i m ofs) (vector-set! v i (inexact->exact (+ ofs (* m (vector-ref v i)))))) (define (random-pos radius cx cy) (let ((pos (make-vector 2))) (random:hollow-sphere! pos *random-state*) (vmac-exact! pos 0 radius cx) (vmac-exact! pos 1 radius cy) pos)) (define (px pos) (vector-ref pos 0)) (define (py pos) (vector-ref pos 1)) (define (px! pos x) (vector-set! pos 0 (inexact->exact x))) (define (py! pos y) (vector-set! pos 1 (inexact->exact y))) (define (draw-edges! d w gc edges) (for-each (lambda (edge) (let ((x0 (px (get (edge-up edge) 'pos))) (y0 (py (get (edge-up edge) 'pos))) (x1 (px (get (edge-down edge) 'pos))) (y1 (py (get (edge-down edge) 'pos)))) (x-draw-line! w gc x0 y0 x1 y1) (x-flush! d) )) edges)) (define pi (* 2 (asin 1))) (define (rotate! mult pos cx cy bye! hello!) (let* ((x (px pos)) (y (py pos)) (dx (- x cx)) (dy (- y cy)) (hyp (sqrt (+ (* dx dx) (* dy dy))))) ; todo: pass in (do ((i 0 (1+ i)) (angle (if (< dx 0) (* (acos (/ dx hyp)) (if (< dy 0) -1 1)) (asin (/ dy hyp))) (+ angle (* mult (/ pi 4 100))))) ((= i 100)) (bye!) (px! pos (+ cx (* (cos angle) hyp))) (py! pos (+ cy (* (sin angle) hyp))) (hello!)))) (define (circle-frisk d w gc show clear) (let* ((center-x (compute-center-x d w)) (center-y (compute-center-y d w)) (egc (erasing-gc d w))) (clear) (show) (format #t "~A modules\n" (length (report 'modules))) (for-each (lambda (module) (put module 'pos (random-pos (* (min center-x center-y) (if (mod-int? module) 0.666666 ; the beast inside! 1)) center-x center-y))) (report 'modules)) (draw-edges! d w gc (report 'edges)) (let loop () (let* ((module (cond (#t (list-ref (report 'modules) (random (length (report 'modules))))) ((member name (report 'modules)) => car) (else #f))) (UP (mod-up-ls module)) (DN (mod-down-ls module)) (edges (append UP DN))) (format #t "~A ~A U:~A D:~A\n" (if (mod-int? module) #\i #\x) module (length UP) (length DN)) (rotate! (- (random 5) 2) (get module 'pos) center-x center-y (lambda () (draw-edges! d w egc edges)) (lambda () (draw-edges! d w gc edges))) (draw-edges! d w gc (report 'edges)) (usleep 400000) (loop))) (clear))) (let ((those (if (member "root" (command-line)) cddr cdr))) (report! (those (command-line)))) (if (null? (report 'modules)) (write-line "no modules specified") (simple-kick circle-frisk)) ;;; circle-frisk ends here _______________________________________________ Guile-user mailing list Guile-user@gnu.org http://mail.gnu.org/mailman/listinfo/guile-user