home *** CD-ROM | disk | FTP | other *** search
/ Fujiology Archive / fujiology_archive_v1_0.iso / !FALCON / NOCREW / MP2_0997.ZIP / mp2_0997 / mp2audio.sho < prev    next >
Text File  |  1999-09-06  |  9KB  |  329 lines
  1. ;;
  2. ;; Set up some frequently used functions.
  3. ;;
  4. (define not (x) (equal x #f))
  5. (define nil? (x) (equal x ()))
  6. (define undef? (x) (equal x #undef))
  7. (define err? (x) (equal x #ERR.))
  8. (define list (#rest x) x)
  9.  
  10. (define > (a b) (not (or (< a b) (equal a b))))
  11. (define <= (a b) (or (< a b) (equal a b)))
  12. (define >= (a b) (not (< a b)))
  13.  
  14. (define or (a b) (if a #t (if b #t #f)))
  15. (define and (a b) (if a (if b #t #f) #f))
  16. (define nor (a b) (not (or a b)))
  17. (define nand (a b) (not (and a b)))
  18. (define xor (a b) (or (and a (not b)) (and (not a) b)))
  19.  
  20. (define symbol? (x) (nor (list? x) (number? x)))
  21.  
  22. (define caar (x) (car (car x)))
  23. (define cadr (x) (car (cdr x)))
  24. (define cdar (x) (cdr (car x)))
  25. (define cddr (x) (cdr (cdr x)))
  26.  
  27. (define cadar (x) (car (cdr (car x))))
  28.  
  29. ;;
  30. ;; List parsing functions.
  31. ;;
  32. (define last (x)
  33.   (if (nil? (cdr x))
  34.       (car x)
  35.     (last (cdr x))))
  36.  
  37. (define size (x)
  38.   (if (nil? x) 0 (+ 1 (size (cdr x)))))
  39.  
  40. ;(define append (#rest x)
  41. ;  ((lambda (append-loop append-one)
  42. ;     (append-loop x ()))
  43. ;   ;; append-one
  44. ;   (lambda (x y) (if (nil? x) y (append-one (car x) (append-loop (cdr x) y))))
  45. ;   ;; append-loop
  46. ;   (lambda (x y) (if (nil? x) y (cons (car x) (append-one (cdr x) y))))))
  47.  
  48. (define reverse (x)
  49.   ((lambda (reverse-loop x)
  50.      (reverse-loop x ()))
  51.    (lambda (x y)
  52.      (if (nil? x) y (reverse-loop (cdr x) (cons (car x) y)))) x))
  53.  
  54. (define member (entry x)
  55.   (if (nil? x) #f
  56.     (if (equal entry (car x)) x
  57.       (member entry (cdr x)))))
  58.  
  59. (define assoc (entry x)
  60.   (if (nil? x) #undef
  61.     (if (equal entry (caar x)) (car x)
  62.       (assoc entry (cdr x)))))
  63.  
  64. (define index (entry x)
  65.   (cadr (assoc entry x)))
  66.  
  67. (define indices (x)
  68.   (if (nil? x) ()
  69.     (cons (caar x) (indices (cdr x)))))
  70.  
  71. (define values (x)
  72.   (if (nil? x) ()
  73.     (cons (cadar x) (values (cdr x)))))
  74.  
  75. (define search (entry x)
  76.   (let ((search-iter (lambda (entry x position)
  77.                (cond ((nil? x) #undef)
  78.                  ((equal entry (car x)) position)
  79.                  (#t (search-iter entry (cdr x) (+ 1 position)))))))
  80.     (search-iter entry x 0)))
  81.  
  82. ;;
  83. ;; Improved flow control.
  84. ;;
  85. (define begin (#rest x) (last x))
  86.  
  87. (define defmacro (macro (m v b)
  88.             (list (quote define) m (list (quote macro) v b))))
  89.  
  90. (defmacro let (variables #rest body)
  91.   (cons (list (quote lambda) (indices variables)
  92.           (append (quote (begin)) body))
  93.     (values variables)))
  94.  
  95. (defmacro backquote (value)
  96.   ((lambda (backquote-rec backquote-iter)
  97.      (backquote-rec value))
  98.    ;; backquote-rec
  99.    (lambda (value)
  100.      (if (nil? value)
  101.      ()
  102.        (if (list? value)
  103.        (if (equal (quote comma) (car value))
  104.            (cadr value)
  105.          (cons (quote list) (backquote-iter value)))
  106.      (list (quote quote) value))))
  107.    ;; backquote-iter
  108.    (lambda (l)
  109.      (if (nil? l)
  110.      ()
  111.        (cons (backquote-rec (car l)) (backquote-iter (cdr l)))))))
  112.  
  113. (defmacro alias (fu-alias fu) (list (quote define) fu-alias (eval fu)))
  114. (alias = equal)
  115.  
  116. (defmacro cond (#rest x)
  117.   (if (nil? x) #f
  118.     (if (nil? (cdr x))
  119.     (list (quote if) (caar x) (cadar x) #f)
  120.       (list (quote if) (caar x) (cadar x)
  121.         (cons (quote cond) (cdr x))))))
  122.  
  123. ;((macro (real-lambda)
  124. ;  (list (quote defmacro) (quote lambda) (quote (v #rest b))
  125. ;    (list (quote list) (eval real-lambda)
  126. ;        (quote v) (quote (cons (quote begin) b))))) lambda)
  127.  
  128. (defmacro map (fu x)
  129.   ((lambda (x)
  130.     (if (nil? x) ()
  131.       (list (quote cons) (list fu (car x))
  132.         (list (quote map) fu (list (quote quote) (cdr x))))))
  133.    (eval x)))
  134.  
  135. (defmacro apply (fu args)
  136.   (eval (cons fu (eval args))))
  137.  
  138. ;;
  139. ;; Enhanced numerical functions.
  140. ;;
  141. (define +1 (x) (+ x 1))
  142. (define -1 (x) (- x 1))
  143.  
  144. ;;
  145. ;; Various example functions.
  146. ;;
  147. (define play (file)
  148.    (begin (mp2-load file)
  149.           (mp2-play)))
  150.  
  151. (define factorial (n)
  152.    (if (< n 1) 1 (* n (factorial (- n 1)))))
  153.  
  154. (define s-to-hms (sec)
  155.    (list (/ sec 3600) (% (/ sec 60) 60) (% sec 60)))
  156.  
  157. (define song-time ()
  158.    (s-to-hms (cadr (assoc "timelength" (mp2-type)))))
  159.  
  160. ;;
  161. ;; Grand old interface.
  162. ;;
  163. (define mp2-find-next (e l)
  164.    (if (nil? (cdr l)) #f
  165.        (if (equal e (car l))
  166.           (cadr l)
  167.          (mp2-find-next e (cdr l)))))
  168.  
  169. (define mp2-find-previous (e l)
  170.    (if (nil? (cdr l)) #f
  171.        (if (equal e (cadr l))
  172.           (car l)
  173.          (mp2-find-previous e (cdr l)))))
  174.  
  175. (define mp2filelist () 
  176.   (let ((uppercase (ls "*.MP?"))
  177.         (lowercase (ls "*.mp?")))
  178.     (if (equal (car uppercase) (car lowercase))
  179.        (sort uppercase)
  180.       (sort (append uppercase lowercase)))))
  181.  
  182. (define mp2-next ()
  183.   (mp2-find-next (index "filename" (mp2-type)) (mp2filelist)))
  184.  
  185. (define mp2-previous ()
  186.   (mp2-find-previous (index "filename" (mp2-type)) (mp2filelist)))
  187.  
  188. (define mp2-load-and-play (filename)
  189.    (if (mp2-load filename)
  190.       (mp2-play)
  191.      #f))
  192.  
  193. ;; Define icons.
  194. (define mp2-icon-stop         () (mp2-stop))
  195. (define mp2-icon-pause        () (mp2-pause))
  196. (define mp2-icon-loop         () (mp2-loop))
  197. (define mp2-icon-info         () (mp2-window-info))
  198. (define mp2-icon-console      () (mp2-window-console))
  199. (define mp2-icon-fast-forward () (mp2-fast-forward))
  200.  
  201. (define mp2-icon-play ()
  202.    (if (or (not (mp2-loaded?)) (mp2-play?))
  203.        (mp2-load-and-play (mp2-select))
  204.      (mp2-play)))
  205.  
  206. (define mp2-icon-load         () (mp2-load (mp2-select)))
  207. (define mp2-icon-next ()
  208.   (if (mp2-play?)
  209.      (mp2-load-and-play (mp2-next))
  210.     (mp2-load (mp2-next))))
  211.  
  212. (define mp2-icon-previous ()
  213.   (if (< 3 (mp2-play-time))
  214.      (begin (mp2-stop) (mp2-play))
  215.     (if (not (if (mp2-play?)
  216.                 (mp2-load-and-play (mp2-previous))
  217.                (mp2-load (mp2-previous))))
  218.        (if (mp2-play?) (begin (mp2-stop) (mp2-play))))))
  219.  
  220. ;; Define hooks.
  221. (define mp2-hook-finitum ()
  222.    (if (mp2-loop?)
  223.        (begin (mp2-stop) (mp2-play))
  224.      (if (equal (mp2-load-and-play (mp2-next)) #f)
  225.         (mp2-stop))))
  226.  
  227. (define mp2-hook-dragumdroppum (filename)
  228.    (begin (mp2-load filename) (mp2-play)))
  229.  
  230. (define mp2-hook-loaditum ()
  231.    (mp2-subtitle (index "filename" (mp2-type))))
  232.  
  233. (mp2-countdown #t)
  234. (mp2-display-time #t)
  235.  
  236. ;;
  237. ;; Define some titles.
  238. ;;
  239. (mp2-title "MP2")
  240. (mp2-subtitle " No song loaded ")
  241.  
  242. ;;
  243. ;; Define control keys.
  244. ;;
  245. (define mp2-control-c () (mp2-icon-console))
  246. (define mp2-control-i () (mp2-icon-info))
  247. (define mp2-control-p () (mp2-icon-play))
  248. (define mp2-control-P () (mp2-icon-pause))
  249. (define mp2-control-s () (mp2-icon-stop))
  250. (define mp2-control-f () (mp2-icon-next))
  251. (define mp2-control-b () (mp2-icon-previous))
  252. (define mp2-control-o () (mp2-icon-load))
  253. (define mp2-control-L () (mp2-icon-loop))
  254. (define mp2-control-F () (mp2-icon-fast-forward))
  255.  
  256. (define mp2-control-t () (mp2-countdown))
  257.  
  258. (define mp2-control-u () (mp2-close-window))
  259. (define mp2-control-w () (mp2-switch-window))
  260. (define mp2-control-l () (mp2-clear-console))
  261. (define mp2-control-q () (exit))
  262.  
  263. ;;
  264. ;; Jukebox mode.
  265. ;;
  266. (define play-list ())
  267.  
  268. (define empty-play-list? ()
  269.    (nil? play-list))
  270.  
  271. (define push-play-list (#rest filenames)
  272.    (if filenames
  273.      (define play-list (append play-list filenames))))
  274.  
  275. (define pop-play-list ()
  276.    (if (empty-play-list?)
  277.          #f
  278.        (let ((filename (car play-list)))
  279.             (begin (define play-list (cdr play-list))
  280.                    filename))))
  281.  
  282. (define juke-play ()
  283.    (if (empty-play-list?)
  284.       #f
  285.      (begin (mp2-subtitle " *Jukebox mode* ")
  286.             (mp2-load (pop-play-list))
  287.             (mp2-subtitle (index "filename" (mp2-type)))
  288.             (mp2-play)
  289.             #t)))
  290.  
  291. ;; Define juke-mode hooks and icons.
  292. (define juke-mode ()
  293.   (begin
  294.     (mp2-subtitle " *Jukebox mode* ")
  295.     
  296.     (define mp2-hook-finitum () 
  297.        (if (not (juke-play)) (mp2-stop)))
  298.  
  299.     (define mp2-hook-dragumdroppum (filename)
  300.        (push-play-list filename))
  301.  
  302.     (define mp2-icon-play ()
  303.        (begin
  304.           (if (and (mp2-loaded?) (not (mp2-play?)))
  305.              (mp2-play)
  306.             (if (or (empty-play-list?) (mp2-play?))
  307.                (mp2-icon-load)))
  308.           (if (not (mp2-play?))
  309.                (juke-play))))
  310.  
  311.     (define mp2-icon-load    () 
  312.        (let ((filename (mp2-select)))
  313.           (if (not (equal filename #f))
  314.              (push-play-list filename))))
  315.  
  316.     (define mp2-icon-next    () (juke-play))
  317.  
  318.     (if (mp2-loaded?) 
  319.        (mp2-subtitle (index "filename" (mp2-type))))
  320.  
  321.     (juke-play)))
  322.  
  323. (define mp2-control-j () (juke-mode))
  324.  
  325. ;; Default position of windows.
  326. (mp2-place-window-control 400 380)
  327. (mp2-place-window-info 500 100)
  328. (mp2-place-window-console 200 350)
  329.