;;; -*- Mode: LISP; Syntax: COMMON-LISP; Base: 10.; Package: XIT -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: XIT
;;;                       Module: SOUNDS
;;;                       Version: 1.0
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Juergen Herczeg
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/kernel/sounds.lisp
;;; File Creation Date: 05/21/91 17:32:19
;;; Last Modification Time: 06/26/92 11:49:08
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;;_____________________________________________________________________________

(in-package :xit)

(defun find-sound-file (filename)
  (declare (special *sound-directory* *sound-extensions*))
  (find-file filename *sound-directory* *sound-extensions*))

;___________________________________________________________________________
;
;                                Composite-Part
;___________________________________________________________________________
#||
;; the following is to be included in intels ...

(defclass composite-node-mixin ()
  ())

(defmethod initialize-instance :after ((self composite-node-mixin)
				       &rest init-list
				       &key parts)
  (declare (ignore init-list))
  (dolist (part parts)
    (apply #'add-part self part)))

(defmethod add-part ((self composite-node-mixin)
		     &rest part-init-list &key class)
  #+LISPM (setq part-init-list (copy-list part-init-list))
  (loop
    (unless (remf part-init-list :class) (return)))
  (apply #'make-instance class part-init-list))

(defmethod parts ((self composite-node-mixin))
  ()) ; to be filled by subclass

(defclass part-node ()
  ((part-of :initform nil :accessor part-of :initarg :part-of)))

(defclass composite-node (composite-node-mixin part-node)
  ((parts :type list :initform nil :accessor parts)))

(defmethod add-part :around ((self composite-node)
			     &rest part-init-list &key class)
  (let ((new-part (call-next-method)))
    (with-slots (parts) self
      (setf parts `(,@parts new-part)))
    new-part))

(defmethod add-part ((self intel)
		     &rest part-init-list &key class)
  #+LISPM (setq part-init-list (copy-list part-init-list))
  (loop
    (unless (remf part-init-list :class) (return)))
  (apply #'make-interaction-object class :part-of self part-init-list))


||#
;___________________________________________________________________________
;
;                                Sound Dispel
;___________________________________________________________________________

(defclass sound-dispel ()
  ((sound :type stringable :accessor sound :initarg :sound)
;  one would like to have the following
;  (volume :type (or null float) :initform nil
;          :accessor volume :initarg :volume)
   (repetition :type integer :initform 1
	       :accessor repetition :initarg :repetition)
   (sound-file)))

(defmethod get-sound-file ((self sound-dispel))
  (with-slots (sound sound-file) self
    (let ((file (find-sound-file sound)))
      (when file (setf sound-file (namestring file))))))

(defmethod initialize-instance :after ((self sound-dispel) &rest init-args)
  (declare (ignore init-args))
  (get-sound-file self))

(defmethod (setf sound) :after (value (self sound-dispel))
  (declare (ignore value))
  (get-sound-file self))

(defun play-sounds (sound-files)
  ;; sound-files is a list of complete pathnames
  (declare (special *default-host* *same-host-p*))
  (ignoring-errors
   #+excl
   (excl::run-shell-command
    (let ((command-string
	   (let ((*print-circle* nil))
	     (format nil "cat ~{ ~A~} > /dev/audio" sound-files))))
      (if *same-host-p*
	  command-string
	(format nil "rsh ~A ~S" *default-host* command-string)))
    :wait t)
#||
   ;; the following doesn't work
   #+lucid
   (if *same-host-p* 
       (lcl::run-program "cat"
			 :arguments `(,@sound-files ">" "/dev/audio")
			 :wait t)
     (lcl::run-program "rsh"
		       :arguments `(,*default-host* "cat" ,@sound-files
						    ">" "/dev/audio")
		       :wait t))
||#
    ))

(defun play-sounds-rep (sound-descrs)
  ;; sound-descrs is a list of entries of the following form:
  ;;  <sound-file> or (<sound-file> . <number>), where <number>
  ;;  denotes the number of repetitions.
  (let ((sound-files
	 (mapcan #'(lambda (sound-descr)
		     (if (consp sound-descr)
			 (make-list (cdr sound-descr)
				    :initial-element (car sound-descr))
		       (list sound-descr)))
		 sound-descrs)))
    (play-sounds sound-files)))

(defun play-sound (sound-file &optional (times 1))
  (play-sounds-rep (list (cons sound-file times))))

(defmethod play ((self sound-dispel))
  (declare (special *default-host* *same-host-p*))
  (with-slots (sound-file repetition) self
    (play-sound sound-file repetition)))

(defun play-sound-dispels-compressed (sound-dispels)
  (play-sounds-rep
   (mapcar #'(lambda (dispel)
	       (cons (slot-value dispel 'sound-file)
		     (repetition dispel)))
	sound-dispels)))  

;___________________________________________________________________________
;
;                                Sound Intel
;___________________________________________________________________________

(defclass sound-intel ()
  ((parts :type list :initform nil)))

(defmethod initialize-instance :after ((self sound-intel) &rest init-args
				       &key parts)
  (declare (ignore init-args))
  ;; to be filled
  )
