[Top][All Lists]

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]


From: Thien-Thi Nguyen
Subject: ~/bin/demo
Date: Wed, 03 Sep 2003 13:01:19 +0200

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.


#!/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 for details.

(define *demos* '())

(defmacro defdemo (name . body)
  `(define ,name
       (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"
           (use-modules (ttn dirutils))
           (lambda ()
             (cons "root"
                    (lambda (file)
                      (and (not-dot-not-dotdot file)
                           (format #f "scripts/~A" file)))

;; 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))

(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))
                                    (error c-n-f-d name))
                                    (format #t "~A: ~A ~A\n" me c-n-f-d name)
                                    (set! exit-val #f)))))
                         (map string->symbol (cdr args)))
           `(usage . ,usage)
           '(package . "~/bin scripts")
           `(version . ,*demo-version*))

;;; demo ends here

reply via email to

[Prev in Thread] Current Thread [Next in Thread]