#!/usr/bin/guile \
--debug -e main -s
!#

;;   Copyright (C) 2002 Ingo Ruhnke <grumbel@gmx.de>
;;     
;;   This program is free software; you can redistribute it and/or modify
;;   it under the terms of the GNU General Public License as published by
;;   the Free Software Foundation; either version 2 of the License, or
;;   (at your option) any later version.
;;
;;   This program is distributed in the hope that it will be useful,
;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;   GNU General Public License for more details.
;;
;;   You should have received a copy of the GNU General Public License
;;   along with this program; if not, write to the Free Software
;;   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.


;; Helper Application to view level information
(use-modules (xml expat)
	     (xml mixp)
	     (ice-9 format)
	     (oop goops)
	     (ice-9 getopt-long))

(define *output-format* 'normal)

(define (file->string filename)
  (let ((port (open-input-file filename))
	(lst  '()))
    (let loop ((line (read-line port)))
      (cond ((not (eof-object? line))
	     (set! lst (cons line lst))
	     (loop (read-line port)))))
    (close port)
    (apply string-append (reverse lst))))

(define (println . str)
  (for-each display str) (newline))

(define-class <pingus-level> ()
  (filename #:accessor filename
	#:init-value #f)

  (author #:accessor author
	  #:init-value #f)
  
  (levelname #:accessor levelname
	     #:init-value #f)
  
  (description #:accessor description
	       #:init-value #f)

  (comment #:accessor comment
	   #:init-value #f)

  (time #:accessor time 
	#:init-value #f)

  (difficulty #:accessor difficulty
	      #:init-value #f)

  (playable #:accessor playable
	    #:init-value #f)

  (number-to-save #:accessor number-to-save
		  #:init-value #f)

  (number-of-pingus #:accessor number-of-pingus
		    #:init-value #f)
  )

(define-method (file->pingus-level (fname <string>))
  (let* ((plf (make <pingus-level>))
	 (document (file->string fname))
	 (xml-tree (call-with-input-string document
					   mixp:xml->tree)))
    (set! (filename plf) (basename fname))
    (plf:parse plf xml-tree)
    plf))

;; Parse a pingus level file
(define-method (plf:parse (plf <pingus-level>) tree)
  (cond ((not (null? tree))
	 (let ((node (car tree)))
	   (cond ((equal? (car node) 'element)
		  (cond ((equal? (caadr node) "pingus-level")
			 (plf:parse-main plf (cddr node)))
			(else
			 (println "Error: Unknown tag: " (caadr node))
			 )))
		 (else
		  (println "Error: " (car node))))))
	(else
	 (plf:parse (cdr tree)))))

;; Parse the <global> part of a pingus level file
(define-method (plf:parse-global (plf <pingus-level>) tree)
  (let ((node (car tree)))
    ;; Insert global check here
    (for-each (lambda (i)
		(case (car i)
		  ((character-data) #f)
		  ((element)
		   ;;(println "El: " i)
		   (cond ((not (null? (cddr i)))
			  (case (string->symbol (caadr i))
			    ((playable)   
			     (set! (playable plf)   (string->number (car (cdaddr i)))))
			    ((difficulty) 
			     (set! (difficulty plf) (string->number (car (cdaddr i)))))
			    ((time)
			     (set! (time plf)       (string->number (car (cdaddr i)))))
			    ((levelname)
			     (set! (levelname plf)     (car (cdaddr i))))
			    ((author)
			     (set! (author plf)     (car (cdaddr i))))
			    ((comment)
			     (set! (comment plf)    (car (cdaddr i))))

			    ((number-of-pingus)
			     (set! (number-of-pingus plf)    (string->number (car (cdaddr i)))))

			    ((number-to-save)
			     (set! (number-to-save plf)    (string->number (car (cdaddr i)))))

			    (else  #f ));;     (println (caadr i))))
			  )))
		  (else (println "Error: global"))))
	      (cdr tree))))

(define-method (plf:parse-main (plf <pingus-level>) tree)
  (cond ((not (null? tree))  
	 (let ((node (car tree)))
	   (case (car node)
	     ((element)	      
	      (case (string->symbol (caadr node))
		((global) (plf:parse-global plf (cdr node)))
		((groundpiece) #f);(println "-groundpiece-: " (caadr node)))
		((liquid)      #f);(println "-liquid-: " (caadr node)))
		((hotspot)     #f);(println "-hotspot-: " (caadr node)))
		((entrance)    #f);(println "-entrance-: " (caadr node)))
		((exit)        #f);(println "-exit-: " (caadr node)))
		(else          #f)));(println "else: " (caadr node)))))
	     ((character-data) 
	      #f);(println "Cdata: " (cdr node )))
	     (else
	      #f);(println "Unknown: " (cdr node)))
	     ))
	 (plf:parse-main plf (cdr tree)))))

;; (type element content ...)

(define (print-usage)
  (println "Usage: pingus-level [OPTIONS]... [LEVELFILES]...")
  (println "")
  (println "  --verbose    Verbose output")
  (println "  --short      Short one-line output for easy parsing. The format is:")
  (println "               filename:playable:difficulty:time")
  (println "  --help       Print this help")
  (newline)
  (println "Examples:")  
  (println "~~~~~~~~~")
  (println "  % pingus-level --short somelevel.xml")
  (println "  % pingus-level --verbose somelevel.xml")
  (newline))

(define grammar '((verbose (required? #f)
			   (single-char #\v)
			   (value #f))
		  (html (required? #f)
			(value #f))
		  (short (required? #f)
			(single-char #\s)
			(value #f))
		  (help (required? #f)
			(single-char #\h)
			(value #f))))

(define-method (print-short-info (plf <pingus-level>))
  (println (filename plf) ":" (playable plf) ":" (difficulty plf) ":" (time plf)))


(define-method (print-html-info (plf <pingus-level>))
  (println "<h2>"(levelname plf) " (" (filename plf) ")</h2>"
	   "<table>"
	   "<tr>" "<td>Author:</td>" "<td>" (author plf) "</td></tr>"
	   "<tr>" "<td>Difficulty:</td>" "<td>" (or (difficulty plf) "not rated") "</td></tr>"
	   "<tr>" "<td>Save Ratio:</td>" "<td>" (number-to-save plf) "/" (number-of-pingus plf) "</td></tr>"
	   "<tr>" "<td>Playable:</td>" "<td>" (or (playable plf) "not tested") "</td></tr>"
	   "<tr>" "<td>Time:</td>" "<td>" (or (time plf) "-") "</td></tr>"
	   "<tr>" "<td>Comment:</td>" "<td>" (or (comment plf) "-") "</td></tr>"
	   "</table>"
	   ))

(define-method (print-long-info (plf <pingus-level>))
  (println "---- Filename:   " (filename plf) " ----")
  (println "Author:     " (author plf))
  (println "Difficulty: " (difficulty plf))
  (println "Playable:   " (playable plf))
  (println "Time:       " (time plf))
  (println "Comment:    " (comment plf))
  (println))

(define (print-level-info fname)
  (catch #t
	 (lambda ()
	   (let ((plf (file->pingus-level fname)))
	     (cond ((equal? *output-format* 'short)
		    (print-short-info plf))
		   ((equal? *output-format* 'html)
		    (print-html-info plf))
		   (else
		    (print-long-info plf)))))
	 (lambda stuff
	   (println fname ":error: " stuff))))

(define (print-html-header)
  (println "<html>
<head>
<title>Pingus Levels</title>
</head>
<body>
<h1>Pingus Levels</h1>"))

(define (print-html-footer)
  (println "<hr><small>automatically generated by the 'pingus-level' tool on " 
	   (strftime "%d. %b %G" (gmtime (current-time)))
	   " </small></body>"))

(define (main args)
  (catch 'misc-error
	 (lambda ()
	   (let ((result (getopt-long args grammar)))
	     (cond ((assoc-ref result 'verbose)
		    (set! *output-format* 'verbose)))
	     (cond ((assoc-ref result 'short)
		    (set! *output-format* 'short)))
	     (cond ((assoc-ref result 'html)
		    (set! *output-format* 'html)))
	     (cond ((assoc-ref result 'help)
		    (print-usage)
		    (exit 0)))
	     (cond ((not (null? (assoc-ref result '())))
		    (cond ((equal? *output-format* 'html)
			   (print-html-header)))
		    (for-each print-level-info
			      (assoc-ref result '()))
		    (cond ((equal? *output-format* 'html)
			   (print-html-footer))))
		   (else
		    (println "Error: You must supply a level-filename. Use --help for more infos.")
		    (exit 1)
		    ))))
	 (lambda err
	   (println "Error while parsing command line args: " err)
	   (exit 1))))

  ;; EOF ;;