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

more commands

Browse Source
This commit is contained in:
Victor Fors 2020-10-11 19:42:25 +02:00
parent 8ea1c84e3e
commit 794a3bf9fb
1 changed files with 67 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
kekkonen.scm
View File

@ -235,6 +235,12 @@
(define (get-hidden object) (define (get-hidden object)
(database-get object 'hidden #f)) (database-get object 'hidden #f))
(define (set-fixed object value)
(database-set object 'fixed value))
(define (get-fixed object value)
(database-get object 'hidden #f))
(define (get-put-message object) (define (get-put-message object)
(database-get object 'put-message "You put the ~a into the ~a.")) (database-get object 'put-message "You put the ~a into the ~a."))
@ -329,9 +335,7 @@
(print-room-description (get-container 'you))) (print-room-description (get-container 'you)))
(define (do-command-examine tag) (define (do-command-examine tag)
(let ((object (match-object tag (if (devmode-enabled?) (let ((object (match-object tag (visible-objects 'you))))
(get-all-objects)
(visible-objects 'you)))))
(if (not object) (if (not object)
(show "You cannot see that here.") (show "You cannot see that here.")
(show (get-description object))))) (show (get-description object)))))
@ -403,6 +407,61 @@
(define (do-command-describe tag description) (define (do-command-describe tag description)
(do-setter-command tag description string? set-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+)))
(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
(case flag
((fixed) (set-fixed object #t))
((hidden) (set-hidden object #t))))))))
(define (do-command-unflag tag flag)
(if (not (and (symbol? tag) (symbol? flag) (member flag +object-flags+)))
(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
(case flag
((fixed) (set-fixed object #f))
((hidden) (set-hidden object #f))))))))
(define (do-command-alias tag alias)
(if (not (and (symbol? tag) (symbol? alias)))
(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
(add-alias object alias)
(show "You add an alias."))))))
(define (do-command-unalias tag alias)
(if (not (and (symbol? tag) (symbol? alias)))
(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
(remove-alias object alias)
(show "You remove an alias."))))))
(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")
(let ((object (match-object tag (visible-objects 'you))))
(if (not object)
(show "You can't see that here.")
(case message-tag
((enter) (set-enter-message object message))
(else (show "Invalid message name.")))))))
(define +cardinal-sets+ (define +cardinal-sets+
'((north n) '((north n)
(northeast ne north-east) (northeast ne north-east)
@ -495,6 +554,11 @@
(('rename x y) (do-command-rename x y)) (('rename x y) (do-command-rename x y))
(('describe x y) (do-command-describe x y)) (('describe x y) (do-command-describe x y))
(('dig x y) (do-command-dig x y)) (('dig x y) (do-command-dig x y))
(('flag x y) (do-command-flag x y))
(('unflag x y) (do-command-unflag x y))
(('alias x y) (do-command-alias x y))
(('unalias x y) (do-command-unalias x y))
(('message x y z) (do-command-message x y z))
(_ (set! success #f))) (_ (set! success #f)))
(set! success #f)))) (set! success #f))))
success)) success))