Author: grumbel Date: 2007-11-01 19:41:02 +0100 (Thu, 01 Nov 2007) New Revision: 3459
Added: trunk/pingus/contrib/levelcheck.scm Log: - some experimences with a levelchecker Added: trunk/pingus/contrib/levelcheck.scm =================================================================== --- trunk/pingus/contrib/levelcheck.scm 2007-11-01 12:11:20 UTC (rev 3458) +++ trunk/pingus/contrib/levelcheck.scm 2007-11-01 18:41:02 UTC (rev 3459) @@ -0,0 +1,116 @@ +#!/usr/bin/guile \ +--debug -e main -s +!# + +(use-modules (ice-9 format)) + +(define *pingu-level-spec* + '(pingus-level (hashmap + (children + (version (int)) + (head + (hashmap + (children + (levelname (string)) + (description (string)) + (author (string)) + (number-of-pingus (int)) + (number-to-save (int)) + (time (int)) + (difficulty (int)) + (playable (int)) + (comment (string)) + (music (string)) + ;; (actions (string)) + ))) + (objects + (sequence + (children + ))) + )))) + +(define (element-position el) + (if (pair? el) + (format #f "~a:~a" + (source-property el 'filename) + (source-property el 'line)) + (format #f "unknown: ~a" el))) + +(define (verify-hashmap spec tree) + (cond ((list? tree) + (let loop ((children (assoc-ref (cdr spec) 'children)) + (subtree tree)) + (if (not (null? children)) + (cond ((null? subtree) + (format #t "~a: Error: Missing elements in:\n~a\nExpected:\n~a\n" + (element-position tree) + tree + children)) + (else + (verify-element (car children) (car subtree)) + + (loop (cdr children) (cdr subtree))))))) + (else + (format #t "~a: Error: Expected hashmap, got " (element-position tree)) + #f))) + +(define (verify-sequenc spec tree) + #t) + +(define (verify-element spec tree) + (let ((tag (car spec)) + (type (cadr spec))) + + (cond ((not (list? tree)) + (format #t "Error: Expected element, got ~a\n" tree) + #f) + + ((equal? tag (car tree)) + (format #t "Element '~a' ok\n" tag) + (cond ((equal? (car type) 'string) + (if (string? (cadr tree)) + #t + (format #t "~a: Error: Expected string element got '~s'\n" + (element-position tree) (cadr tree)))) + ((equal? (car type) 'int) + (if (integer? (cadr tree)) + #t + (format #t "~a: Error: Expected integer element got '~s'\n" + (element-position tree) (cadr tree)))) + ((equal? (car type) 'real) + (if (real? (cadr tree)) + #t + (format #t "~a: Error: Expected real element got '~s'\n" + (element-position tree) (cadr tree)))) + ((equal? (car type) 'bool) + (if (boolean? (cadr tree)) + #t + (format #t "~a: Error: Expected bool element got '~s'\n" + (element-position tree) (cadr tree)))) + ((equal? (car type) 'hashmap) + (verify-hashmap type (cdr tree))) + ((equal? (car type) 'sequence) + #t (verify-sequenc type (cdr tree))))) + (else + (format #t "Error: Expected element '~a', but got '~a'\n" tag (car tree)) + #f)))) + +(define (read-file filename) + (let* ((port (open-input-file filename)) + (ret (read port))) + (close-input-port port) + ret)) + +(define (main args) + (read-enable 'positions) + + (cond ((= (length args) 1) + (format #t "Usage: ~a FILENAME...\n" (car args))) + (else + (for-each (lambda (filename) + (format #t "Filename: '~a'\n" filename) + (let ((content (read-file filename))) + (verify-element *pingu-level-spec* content))) + (cdr args))))) + +; EOF ;; Property changes on: trunk/pingus/contrib/levelcheck.scm ___________________________________________________________________ Name: svn:executable + * _______________________________________________ pingus-cvs mailing list [email protected] http://lists.nongnu.org/mailman/listinfo/pingus-cvs
