~/bin/demo

suppose you "work" at home and your inquisitive spouse, sibling, child,
neighbor, wandering postal worker, etc. asks you: "what the hell do you
actually DO on that computer?".  maybe the program below (munged to
taste) can help you answer them and get back to doing whatever you were
actually doing.

munging-to-taste hints: replace and/or augment "Projector demos" and
"guile-xlib demos" sections w/ other `defdemo' forms.  and so on.

thi


_____________________________________
#!/home/ttn/local/bin/guile -s
!#
;;; demo

(define *demo-version* "time-stamp: <2003-09-03 12:36:54 ttn>")

;;; Copyright (C) 2003 Thien-Thi Nguyen
;;; This program is released under GNU GPL v2 with ABSOLUTELY
;;; NO WARRANTY.  See http://www.gnu.org/copyleft/gpl.txt for details.

(define *demos* '())

(defmacro defdemo (name . body)
  `(define ,name
     (begin
       (set! *demos* (cons ',name *demos*))
       (lambda () ,@body))))

(define (child dir name . args)
  ;; ARGS can be a list of strings, or a thunk (evaluated after changing
  ;; directory to DIR) that returns a list of strings.
  (let ((pid (primitive-fork)))
    (if (= 0 pid)
        (let ((program (format #f "./~A" name))
              (args-thunk (if (and (not (null? args))
                                   (thunk? (car args)))
                              (car args)
                              (lambda () args))))
          (chdir dir)
          (let ((new-command-line `(,program ,@(args-thunk))))
            (set! command-line (lambda () new-command-line)))
          (load-from-path program))
        (waitpid pid))))

;; Projector demos

(define (Projector-demo name)
  (child "/home/ttn/build/MISC/Projector/examples" (format #f "~A.scm" name)))

(defdemo Projector-ttn            (Projector-demo 'ttn))
(defdemo Projector-testsdl        (Projector-demo 'testsdl))
(defdemo Projector-testprimitives (Projector-demo 'testprimitives))

;; guile-xlib demos

(defdemo circle-frisk
  (child "/home/ttn/codebits/scheme/xplay" "circle-frisk"
         (begin
           (use-modules (ttn dirutils))
           (lambda ()
             (cons "root"
                   (filtered-files
                    (lambda (file)
                      (and (not-dot-not-dotdot file)
                           (format #f "scripts/~A" file)))
                    "scripts"))))))

;; everything else

(set! *demos* (reverse *demos*))

(define (usage)
  (apply string-append
         "Usage: demo DEMO\n"
         "Run demonstration program DEMO, one of:\n"
         (map (lambda (d)
                (format #f "  ~A\n" d))
              *demos*)))

(use-modules ((scripts PROGRAM) :select (HVQC-MAIN)))

(HVQC-MAIN (command-line)
           (lambda (args)
             (cond ((= 1 (length args))
                    (display (usage))
                    (exit #t)))
             (let ((only-one? (= 2 (length args)))
                   (me (car args))
                   (c-n-f-d "could not find demo:")
                   (exit-val #t))       ; optimism is ok sometimes
               (for-each (lambda (name)
                           (let ((demo (false-if-exception (eval name))))
                             (cond ((thunk? demo)
                                    (or only-one?
                                        (format #t "~A: running demo: ~A\n"
                                                me name))
                                    (demo))
                                   (only-one?
                                    (error c-n-f-d name))
                                   (else
                                    (format #t "~A: ~A ~A\n" me c-n-f-d name)
                                    (set! exit-val #f)))))
                         (map string->symbol (cdr args)))
               exit-val))
           `(usage . ,usage)
           '(package . "~/bin scripts")
           `(version . ,*demo-version*))

;;; demo ends here


_______________________________________________
Guile-user mailing list
[email protected]
http://mail.gnu.org/mailman/listinfo/guile-user