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

nyaa

Browse Source
This commit is contained in:
Victor Fors 2021-08-15 18:52:52 +02:00
parent 794a3bf9fb
commit b35a815aa3
1 changed files with 157 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

178
kekkonen.scm
View File

@ -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))))