whiteline/kekkonen
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

put

Browse Source
This commit is contained in:
Victor Fors 2020-10-01 13:54:23 +02:00
parent a528be6545
commit 239e6afa0a
1 changed files with 30 additions and 4 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
kekkonen.scm
View File

@ -8,8 +8,8 @@
(import ansi-escape-sequences)
(import (chicken file))
; (define (lift fn parser)
; (bind parser (compose result fn)))
(define (lift fn parser)
(bind parser (compose result fn)))
(define (is-not x)
(satisfies (lambda (y)
@ -21,8 +21,15 @@
(define skip-whitespace
(skip (zero-or-more (is #\space))))
(define +letter-char-set+
(string->char-set "abcdefghijklmnopqrstuvxyzABCDEFGHIJKLMNOPQRSTUVXYZ"))
(define +symbol-char-set+
(char-set-union +letter-char-set+ (string->char-set "-0123456789")))
(define parse-symbol
(lift (compose string->symbol string-downcase list->string) (one-or-more (in char-set:letter))))
(lift (compose string->symbol string-downcase list->string (cut apply append <>))
(sequence (lift list (in +letter-char-set+)) (zero-or-more (in +symbol-char-set+)))))
(define parse-number
(lift (compose string->number list->string) (one-or-more (in char-set:digit))))
@ -108,6 +115,13 @@
(begin (display "I didn't quite understand that.")
(adventure-prompt)))))
(define (compose-symbols . ln)
(let loop ((ln ln))
(case (length ln)
((0) '())
((1) (list (symbol->string (car ln))))
(else (string-append (symbol->string (car ln)) "-" (loop (cdr ln)))))))
(define *database* '())
(define (database-set name key value)
@ -205,6 +219,9 @@
(if (member alias aliases)
(set-aliases object (remove (cut eq? alias <>) aliases)))))
(define (get-put-message object)
(database-get object 'put-message "You put the ~a into the ~a."))
;; Is development mode enabled?
(define (devmode-enabled?)
@ -330,6 +347,15 @@
(show (string-append "You drop " (get-name object) "."))
(move-object object (get-container 'you)))))))
(define (do-command-put tag destination-tag)
(let ((object (match-object tag (get-contents 'you))))
(if (not object)
(show "You are not carrying that.")
(let ((destination-object (match-object destination-tag (visible-objects 'you))))
(if (not destination-object)
(show "You cannot see that here.")
(move-object object (get-destination destination-object)))))))
(define (do-command-devmode)
(toggle-devmode)
(if (devmode-enabled?)
@ -352,7 +378,7 @@
(show "That object doesn't exist.")
(begin
(set-name tag name)))))
+
(define (do-command-describe tag description)
(if (not (and (symbol? tag) (string? description)))
(show "I didn't quite understand that.")