|
|
@@ -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 "<b>") (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)))) |
|
|
|