;*=====================================================================*/
;*    serrano/prgm/project/bigloo/tutorial/xmcd.scm                    */
;*    -------------------------------------------------------------    */
;*    Author      :  Manuel Serrano                                    */
;*    Creation    :  Thu Jan  1 16:33:34 1998                          */
;*    Last change :  Mon Jan 22 14:53:35 2001 (serrano)                */
;*    -------------------------------------------------------------    */
;*    The xmcd interface                                               */
;*=====================================================================*/

;*---------------------------------------------------------------------*/
;*    The module                                                       */
;*---------------------------------------------------------------------*/
(module xmcd
   (import tutorial)
   (export *xmcd-db*
	   (make-xmcd-name title id kind)
	   (add-xmcd-db id kind title author songs)))

;*---------------------------------------------------------------------*/
;*    *xmcd-db* ...                                                    */
;*---------------------------------------------------------------------*/
(define *xmcd-db* "cddb")

;*---------------------------------------------------------------------*/
;*    make-xmcd-name ...                                               */
;*---------------------------------------------------------------------*/
(define (make-xmcd-name title id kind)
   (cond
      ((not (string? id))
       (error "cdisc" "Illegal disc id" title))
      ((not (string? kind))
       (error "cdisc" "Illegal disc kind" title))
      (else
       (let ((pathname (make-file-name *xmcd-db* kind)))
	  (if (not (=fx (makedir pathname) 0))
	      (error "make-xmcd-name" "Can't create directory" pathname)
	      (make-file-name (make-file-name *xmcd-db* kind) id))))))

;*---------------------------------------------------------------------*/
;*    add-xmcd-db ...                                                  */
;*---------------------------------------------------------------------*/
(define (add-xmcd-db id kind title author songs)
   (let loop ((id    id)
	      (songs songs))
      (if (pair? id)
	  (begin
	     (add-xmcd-db-entry (car id) kind title author (car songs))
	     (loop (cdr id) (cdr songs))))))
	  
;*---------------------------------------------------------------------*/
;*    add-xmcd-db-endtry ...                                           */
;*---------------------------------------------------------------------*/
(define (add-xmcd-db-entry id kind title author songs)
   (let* ((fname (make-xmcd-name *src* id kind))
	  (out   (open-output-file fname)))
      (if (output-port? out)
	  (unwind-protect
	     (fprint out "# xmcd 2.0 CD database file")
	     (display "# generated by cdisc at " out)
	     (display (date) out)
	     (newline out)
	     (fprint out "#")
	     (fprint out "DISCID=" (8bits->7bits id))
	     (fprint out "DTITLE="
		     (8bits->7bits author) ": "
		     (8bits->7bits title))
	     (let loop ((songs songs)
			(num   0))
		(if (pair? songs)
		    (begin
		       (fprint out "TTITLE" num "="
			       (8bits->7bits (car (car songs))))
		       (loop (cdr songs) (+fx num 1)))))
	     (fprint out "EXTD=")
	     (let loop ((songs songs)
			(num   0))
		(if (pair? songs)
		    (begin
		       (fprint out "EXTT" num "=")
		       (loop (cdr songs) (+fx num 1)))))
	     (fprint out "PLAYORDER=")
	     (close-output-port out)))))

;*---------------------------------------------------------------------*/
;*    8bits->7bits ...                                                 */
;*---------------------------------------------------------------------*/
(define (8bits->7bits string)
   (let ((len (string-length string)))
      (let loop ((i 0))
	 (if (=fx i len)
	     string
	     (begin
		(case (string-ref string i)
		   ((#\é #\è)
		    (string-set! string i #\e))
		   ((#\É #\È)
		    (string-set! string i #\E))
		   ((#\à)
		    (string-set! string i #\a))
		   ((#\À)
		    (string-set! string i #\A))
		   ((#\û #\ü)
		    (string-set! string i #\u))
		   ((#\Û #\Ü)
		    (string-set! string i #\U))
		   ((#\î #\ï)
		    (string-set! string i #\i))
		   ((#\Î #\Ï)
		    (string-set! string i #\I))
		   ((#\ö #\ô)
		    (string-set! string i #\o))
		   ((#\Ö #\Ô)
		    (string-set! string i #\O))
		   ((#\ç)
		    (string-set! string i #\c))
		   ((#\C)
		    (string-set! string i #\C)))
		(loop (+fx i 1)))))))