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 ansi-escape-sequences)
(import (chicken file)) (import (chicken file))
; (define (lift fn parser) (define (lift fn parser)
; (bind parser (compose result fn))) (bind parser (compose result fn)))
(define (is-not x) (define (is-not x)
(satisfies (lambda (y) (satisfies (lambda (y)
@ -21,8 +21,15 @@
(define skip-whitespace (define skip-whitespace
(skip (zero-or-more (is #\space)))) (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 (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 (define parse-number
(lift (compose string->number list->string) (one-or-more (in char-set:digit)))) (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.") (begin (display "I didn't quite understand that.")
(adventure-prompt))))) (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* '())
(define (database-set name key value) (define (database-set name key value)
@ -205,6 +219,9 @@
(if (member alias aliases) (if (member alias aliases)
(set-aliases object (remove (cut eq? 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? ;; Is development mode enabled?
(define (devmode-enabled?) (define (devmode-enabled?)
@ -330,6 +347,15 @@
(show (string-append "You drop " (get-name object) ".")) (show (string-append "You drop " (get-name object) "."))
(move-object object (get-container 'you))))))) (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) (define (do-command-devmode)
(toggle-devmode) (toggle-devmode)
(if (devmode-enabled?) (if (devmode-enabled?)
@ -352,7 +378,7 @@
(show "That object doesn't exist.") (show "That object doesn't exist.")
(begin (begin
(set-name tag name))))) (set-name tag name)))))
+
(define (do-command-describe tag description) (define (do-command-describe tag description)
(if (not (and (symbol? tag) (string? description))) (if (not (and (symbol? tag) (string? description)))
(show "I didn't quite understand that.") (show "I didn't quite understand that.")