diff --git a/kekkonen.scm b/kekkonen.scm index eda7a44..4d41aad 100644 --- a/kekkonen.scm +++ b/kekkonen.scm @@ -5,6 +5,8 @@ (import srfi-13) (import matchable) (import fmt) +(import fmt-color) +(import fmt-unicode) (import ansi-escape-sequences) (import (chicken file)) (import breadline) @@ -16,6 +18,18 @@ (satisfies (lambda (y) (not (eqv? x y))))) +(define (curry fn a) + (lambda (b) + (fn a b))) + +(define (applied fn) + (curry apply fn)) + +(define-syntax thunk + (syntax-rules () + ((_ exp ...) + (lambda () exp ...)))) + (define parse-whitespace (one-or-more (is #\space))) @@ -29,7 +43,7 @@ (char-set-union +letter-char-set+ (string->char-set "-0123456789"))) (define parse-symbol - (lift (compose string->symbol string-downcase list->string (cut apply append <>)) + (lift (compose string->symbol string-downcase list->string (applied append)) (sequence (lift list (in +letter-char-set+)) (zero-or-more (in +symbol-char-set+))))) (define parse-number @@ -67,11 +81,15 @@ (compose (just newline) display)) (define (display-lines ln) - (perhaps (cut map display-newline <>) ln)) + (perhaps (curry map display-newline) ln)) (define (parse-input) (parse (completely-parse parse-statement) (read-line))) +(define parse-formatter + (recursive-parser (one-or-more (any-of (followed-by-consuming (char-seq "") (lift fmt-bold parser)) + (is-not #\<))))) + (define (type-of elem) (cond ((pair? elem) 'pair) ((symbol? elem) 'symbol) @@ -161,10 +179,19 @@ (loop (cdr kv)))))) (define (database-save filename) - (with-output-to-file filename (cut write *database*))) + (with-output-to-file filename (thunk (write *database*)))) (define (database-load filename) - (with-input-from-file filename (lambda () (set! *database* (car (read-list)))))) + (with-input-from-file filename (thunk (set! *database* (car (read-list)))))) + +(define (database-remove name) + (let loop ((kv *database*)) + (if (null? kv) + '() + (if (equal? name (caar kv)) + (cdr kv) + (cons (car kv) (loop (cdr kv))))))) + (define (get-all-objects) (map car *database*)) @@ -227,7 +254,7 @@ (define (remove-alias object alias) (let ((aliases (get-aliases object))) (if (member alias aliases) - (set-aliases object (remove (cut eq? alias <>) aliases))))) + (set-aliases object (remove (curry eq? alias) aliases))))) (define (set-hidden object value) (database-set object 'hidden value)) @@ -282,24 +309,116 @@ (if (not (member object contents)) (begin (database-set container 'contents (cons object contents)) - (database-set prev-container 'contents (remove (cut eq? object <>) (get-contents prev-container)))))))) + (database-set prev-container 'contents (remove (curry eq? object) (get-contents prev-container)))))))) ;; Determine the objects visible to a source object, zork-style (define (visible-objects source) (let ((result (get-container source))) - (if (and result (object-exists? result)) - (cons (get-container source) (get-contents (get-container source))) - (error "Tried to determine visible objects for object without a container.")))) + (if (and result (object-exists? result)) + (cons (get-container source) (get-contents (get-container source))) + (error "Tried to determine visible objects for object without a container.")))) + +(define (any-or fn ln thunk) + (let loop ((ln ln)) + (if (null? ln) + (thunk) + (let ((result (fn (car ln)))) + (if result + result + (loop (cdr ln))))))) + +(define (lisp body environments exit) + (define (eval body) + (lisp body environments exit)) + (define (reference symbol) + (cdr (any-or (curry assoc symbol) environments (exit (string-append "Undefined reference: " (symbol->string symbol)))))) +; (define (apply function function-args) +; (if + (if (atom? body) + (if (symbol? body) + (reference body) + body) + (let ((function-name (car body)) + (function-args (cdr body))) + (if (symbol? function-name) + (case function-name + ((test) (show "test function called")) + ((if) (match function-args + ((e x y) (if (eval e) + (eval x) + (eval y))) + (_ (exit "malformed if expression")))) + ((quote) (match function-args + ((v) v) + (_ (exit "malformed quote expression")))) + ((cons) (match function-args + ((a b) (cons (eval a) (eval b))) + (_ (exit "malformed cons expression")))) + ((car) (match function-args + ((a) (let ((ae (eval a))) + (if (atom? ae) + (exit "tried to take car of atom") + (car (eval a))))) + (_ (exit "malformed car expression")))) + ((cdr) (match function-args + ((a) (cdr (eval a))))) + ((atom) (match function-args + ((a) (atom? (eval a))) + (_ (exit "malformed atom expression")))) + ((eq) (match function-args + ((a b) (equal? (eval a) (eval b))) + (_ (exit "malformed eval expression")))) +; ((set) (match function-args +; ((a b) (if ( + ((lambda) (match function-args + ((args exp . exps) + (if (and (list? args) (every symbol? args)) + (cons args (cons exp exps)) + (exit "malformed lambda expression"))) + (_ (exit "malformed lambda expression")))) + (else (let ((function (reference function-name environments))) + (let ((function-arguments (car function)) + (argument-values (cdr body)) + (function-body (cddr function))) + (lisp function-body (cons (if (= (length function-arguments) (length argument-values)) + (map cons function-arguments (map eval argument-values)) + (exit "Wrong number of arguments to function")) environments exit)))))) + (exit "attempt to call atom"))))) + +(define (run-lisp body) + (call/cc (lambda (exit) + (cons #t (lisp body '(()) (compose exit (curry cons #f))))))) + + +;; (if (and (list function) +;; (>= (length function) 2) +;; (list function-arguments) +;; (every symbol? (car function))) + +(define +script-primitives+ + `((if . ,(lambda (condition body1 body2) + (script (if (script condition) + body1 + body2)))) + (eq . ,(lambda (a b) + (equals? (script a) (script b)))) + (and . ,(lambda (a b) + (and (script a) (script b)))) + (or . ,(lambda (a b) + (or (script a) (script b)))) + (not . ,(lambda (a) + (not (script a)))))) (define (print-room-description room) (newline) (display (set-text '(bold) (get-name room))) + (if (devmode-enabled?) (display (set-text '(bold fg-green) (string-append " [" (symbol->string room) "]")))) (newline) (display " ") (fmt #t (dsp (wrap-lines (get-description room)))) (newline) (display "You see: ") - (map (lambda (n) (if (not (get-hidden n)) (begin (display (get-name n)) (display " ")))) (remove (cut eq? 'you <>) (get-contents room))) + (map (lambda (n) (if (not (get-hidden n)) (begin (display (get-name n)) (display " ") (if (devmode-enabled?) (begin (display (set-text '(bold fg-green) (string-append "[" (symbol->string n) "] ")))))))) (remove (curry eq? 'you) (get-contents room))) (newline)) (define (do-command-enter tag) @@ -407,11 +526,8 @@ (define (do-command-describe tag description) (do-setter-command tag description string? set-description)) -(define +object-flags+ - '(fixed hidden)) - (define (do-command-flag tag flag) - (if (not (and (symbol? tag) (symbol? flag) (member flag +object-flags+))) + (if (not (and (symbol? tag) (symbol? flag))) (show "I didn't quite understand that.") (let ((object (match-object tag (visible-objects 'you)))) (if (not object) @@ -419,10 +535,11 @@ (begin (case flag ((fixed) (set-fixed object #t)) - ((hidden) (set-hidden object #t)))))))) + ((hidden) (set-hidden object #t)) + (else (show "Invalid flag name.")))))))) (define (do-command-unflag tag flag) - (if (not (and (symbol? tag) (symbol? flag) (member flag +object-flags+))) + (if (not (and (symbol? tag) (symbol? flag))) (show "I didn't quite understand that.") (let ((object (match-object tag (visible-objects 'you)))) (if (not object) @@ -430,7 +547,8 @@ (begin (case flag ((fixed) (set-fixed object #f)) - ((hidden) (set-hidden object #f)))))))) + ((hidden) (set-hidden object #f)) + (else (show "Invalid flag name.")))))))) (define (do-command-alias tag alias) (if (not (and (symbol? tag) (symbol? alias))) @@ -452,6 +570,22 @@ (remove-alias object alias) (show "You remove an alias.")))))) +(define (do-command-destroy tag) + (if (not (symbol? tag)) + (show "I didn't quite understand that.") + (database-remove tag))) + +(define (do-command-aliases tag) + (if (not (symbol? tag)) + (show "I didn't quite understand that.") + (let ((object (match-object tag (visible-objects 'you)))) + (if (not object) + (show "You can't see that here.") + (begin + (newline) + (map (lambda (x) (display x) (display " ")) (get-aliases object)) + (newline)))))) + (define (do-command-message tag message-tag message) (if (not (and (symbol? tag) (symbol? message-tag) (string? message))) (show "I didn't quite understand that") @@ -487,10 +621,10 @@ (down . up))) (define (get-cardinal-set direction) - (find (cut member direction <>) +cardinal-sets+)) + (find (curry member direction) +cardinal-sets+)) (define (get-cardinal-aliases direction) - (perhaps (cut remove (cut eq? direction <>) <>) (get-cardinal-set direction))) + (perhaps (curry remove (curry eq? direction)) (get-cardinal-set direction))) (define (cardinal-direction? direction) (list? (member direction (flatten +cardinal-sets+)))) @@ -514,7 +648,7 @@ (move-object exit-tag (get-container 'you)) (set-hidden exit-tag #t) (set-destination exit-tag destination) - (map (cut add-alias exit-tag <>) (get-cardinal-set direction)) + (map (curry add-alias exit-tag) (get-cardinal-set direction)) (show "You create a passage.")))))))) (define (do-command-exit) @@ -530,7 +664,7 @@ (('go x) `(enter ,x)) (('get x) `(take ,x)) ((x) (if (cardinal-direction? x) - `(enter ,x) + `(enter ,x) input)) (_ input))) @@ -558,6 +692,8 @@ (('unflag x y) (do-command-unflag x y)) (('alias x y) (do-command-alias x y)) (('unalias x y) (do-command-unalias x y)) + (('destroy x) (do-command-destroy x)) + (('aliases x) (do-command-aliases x)) (('message x y z) (do-command-message x y z)) (_ (set! success #f))) (set! success #f))))