2020-01-02 00:49:21 -06:00
|
|
|
;; This file is free software: you can redistribute it and/or modify
|
|
|
|
;; it under the terms of version 3 of the GNU General Public License
|
|
|
|
;; as published by the Free Software Foundation.
|
|
|
|
;;
|
|
|
|
;; This program is distributed in the hope that it will be useful,
|
|
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
;; GNU General Public License for more details.
|
|
|
|
|
2020-01-14 23:46:57 -06:00
|
|
|
;; TODO: Get :x-if.interpret to make ACTION objects.
|
2020-01-02 00:49:21 -06:00
|
|
|
|
|
|
|
;; —————————————————————————————————————
|
|
|
|
;; PACKAGES
|
|
|
|
|
|
|
|
(defpackage :x-if
|
2020-01-14 23:46:57 -06:00
|
|
|
(:use :cl)
|
2020-01-02 00:49:21 -06:00
|
|
|
(:nicknames :xif))
|
|
|
|
|
2020-01-10 17:19:45 -06:00
|
|
|
(defpackage :x-if.misc
|
2020-01-14 23:46:57 -06:00
|
|
|
(:use :cl :anaphora)
|
2020-01-10 17:19:45 -06:00
|
|
|
(:nicknames :xif.m)
|
2020-01-14 23:46:57 -06:00
|
|
|
(:export :line-cdr :line-car
|
|
|
|
:line-length :line-position
|
|
|
|
:in-string-p
|
|
|
|
:remove-line
|
|
|
|
:position-equal))
|
2020-01-10 17:19:45 -06:00
|
|
|
|
2020-01-02 00:49:21 -06:00
|
|
|
(defpackage :x-if.lexicon
|
2020-01-14 23:46:57 -06:00
|
|
|
(:use :cl :earley-parser)
|
2020-01-02 00:49:21 -06:00
|
|
|
(:nicknames :xif.l)
|
|
|
|
(:export :action-indirect-required-p :action-direct-required-p
|
2020-01-14 23:46:57 -06:00
|
|
|
:action-p :action-function :add-action :add-verb :remove-word
|
|
|
|
*string-lexicon* *lexicon*
|
|
|
|
:add-game-object-words :delete-game-object-words
|
|
|
|
:add-adjective :add-noun :add-proper-noun :add-verb
|
|
|
|
:reload-lexicon))
|
2020-01-02 00:49:21 -06:00
|
|
|
|
|
|
|
(defpackage :x-if.environment
|
2020-01-14 23:46:57 -06:00
|
|
|
(:use :cl :bknr.datastore)
|
2020-01-02 00:49:21 -06:00
|
|
|
(:nicknames :xif.e)
|
2020-01-14 23:46:57 -06:00
|
|
|
(:export :id→game-object :get-player
|
|
|
|
:all-game-objects
|
|
|
|
:noun→game-objects :proper-noun→game-objects :adjective→game-objects
|
|
|
|
:all-entities
|
|
|
|
:noun→entities :proper-noun→entities :adjective→entities
|
|
|
|
:all-mobs
|
|
|
|
:noun→mobs :proper-noun→mobs :adjective→mobs
|
|
|
|
:noun→locations :proper-noun→locations :adjective→locations
|
|
|
|
:all-locations
|
|
|
|
:id :description
|
|
|
|
:nouns :proper-nouns :adjectives
|
|
|
|
:max-children :weight :hp :max-hp
|
|
|
|
:children :parent
|
|
|
|
:link :unlink))
|
2020-01-02 00:49:21 -06:00
|
|
|
|
|
|
|
(defpackage :x-if.parsing
|
2020-01-14 23:46:57 -06:00
|
|
|
(:use :cl)
|
2020-01-02 00:49:21 -06:00
|
|
|
(:nicknames :xif.p)
|
|
|
|
(:export :parse
|
|
|
|
:noun-phrases :det :prep :proper-noun :noun-name :det :prep
|
|
|
|
:nominal-phrase :noun
|
|
|
|
:verb-phrase :verb :direct-object :indirect
|
|
|
|
:the-action :the-subject))
|
|
|
|
|
|
|
|
(defpackage :x-if.interpret
|
2020-01-14 23:46:57 -06:00
|
|
|
(:use :cl)
|
2020-01-02 00:49:21 -06:00
|
|
|
(:nicknames :xif.i))
|
|
|
|
|
|
|
|
(defpackage :x-if.client
|
2020-01-14 23:46:57 -06:00
|
|
|
(:use :cl :xif.e :bknr.datastore)
|
2020-01-02 00:49:21 -06:00
|
|
|
(:nicknames :xif.c)
|
|
|
|
(:export :start
|
|
|
|
:text :input-sentence :display-options :input-options :play-music
|
|
|
|
:show-image :status :prompt))
|
|
|
|
|
|
|
|
(defpackage :x-if.client.terminal
|
2020-01-14 23:46:57 -06:00
|
|
|
(:use :cl :xif.e)
|
2020-01-02 00:49:21 -06:00
|
|
|
(:nicknames :xif.c.t))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; —————————————————————————————————————
|
|
|
|
;; X-IF.PARSING
|
|
|
|
;; SENTENCE PARSING
|
|
|
|
|
|
|
|
(in-package :x-if.parsing)
|
|
|
|
|
|
|
|
;; —————————————————————————————————————
|
|
|
|
|
|
|
|
;; This package will take a sentence (string) and turn it into an
|
|
|
|
;; easily-parseable tree. It also provides some functions to make parsing this
|
|
|
|
;; tree easy. It does not, however, actually “process” the sentence for the
|
|
|
|
;; game engine itself— that's :x-if.interpret's job.
|
|
|
|
|
|
|
|
;; It doesn't define the lexicon, either. That's :x-if.environment's job.
|
|
|
|
|
|
|
|
;; This uses Earley parse-trees from :cl-earley-parser— so, when a function
|
|
|
|
;; says "tree", it means a list with a identifying car and several sublists.
|
|
|
|
;; For example, here's a noun-phrase's tree:
|
|
|
|
|
|
|
|
;; ("NP" ("proper-noun" "Princess") (prep "beside"))
|
|
|
|
|
|
|
|
;; A "full tree" is the tree of an entire statement— not a sub-tree thereof.
|
|
|
|
;; The only functions that require the full statement tree is #'the-subject
|
|
|
|
;; and #'the-action, so don't sweat it.
|
|
|
|
|
|
|
|
;; —————————————————————————————————————
|
|
|
|
|
|
|
|
;; STRING → LIST_OF_TREES
|
|
|
|
(defun parse (sentence)
|
|
|
|
"Parse a given string into a list of Earley trees."
|
|
|
|
(mapcar #'car
|
|
|
|
(mapcar #'parse-statement
|
2020-01-10 17:19:45 -06:00
|
|
|
(mapcar #'clean-statement (split-statements sentence)))))
|
2020-01-02 00:49:21 -06:00
|
|
|
|
|
|
|
;; —————————————————————————————————————
|
|
|
|
|
|
|
|
;; STRING → TREE
|
|
|
|
(defun parse-statement (statement)
|
|
|
|
"Parse a given statement into an Earley tree."
|
|
|
|
(earley-parser:chart-listing->trees
|
|
|
|
(earley-parser:earley-parse statement
|
|
|
|
(earley-parser:load-bnf-grammar #p"example/grammar.txt")
|
2020-01-14 23:46:57 -06:00
|
|
|
xif.l:*lexicon*)))
|
2020-01-02 00:49:21 -06:00
|
|
|
|
|
|
|
(defun split-statements (sentence)
|
|
|
|
"Split up a string into different statements, based on punctuation."
|
|
|
|
(cl-strings:split sentence ","))
|
|
|
|
|
|
|
|
(defun clean-statement (statement) statement)
|
|
|
|
|
|
|
|
;; —————————————————————————————————————
|
|
|
|
|
|
|
|
;; TREE → LIST_OF_TREES_OF_NOUN_PHRASES
|
|
|
|
(defun noun-phrases (tree)
|
|
|
|
"Return the noun-phrases within a given tree."
|
|
|
|
(let ((phrase nil))
|
|
|
|
(loop :while (setf phrase (assoc "NP" (cdr tree) :test #'equal))
|
|
|
|
:collect phrase
|
|
|
|
:do (setq tree (remove phrase tree)))))
|
|
|
|
|
|
|
|
;; TREE → TREE_OF_VERB_PHRASE
|
|
|
|
(defun verb-phrase (tree)
|
|
|
|
"Return a tree's verb-phrase."
|
|
|
|
(assoc "VP" (cdr tree) :test #'equal))
|
|
|
|
|
|
|
|
;; TREE_OF_VERB_PHRASE → TREE_OF_NOUN_PHRASE
|
|
|
|
(defun direct-object (verb-phrase)
|
|
|
|
"Return a verb-phrase's direct object."
|
|
|
|
(loop :for n-p :in (noun-phrases verb-phrase)
|
|
|
|
:if (not (prep n-p))
|
|
|
|
:return n-p))
|
|
|
|
|
|
|
|
;; TREE_OF_VERB_PHRASE → TREE_OF_NOUN_PHRASE
|
|
|
|
(defun indirect-object (verb-phrase)
|
|
|
|
"Return a verb-phrase's indirect object."
|
|
|
|
(loop :for n-p :in (noun-phrases verb-phrase)
|
|
|
|
:if (prep n-p)
|
|
|
|
:return n-p))
|
|
|
|
|
|
|
|
;; TREE_OF_NOUN_PHRASE → TREE_OF_NOMINAL_PHRASE
|
|
|
|
(defun nominal (noun-phrase)
|
|
|
|
"Return the nominal of a noun— how it's referred to."
|
|
|
|
(assoc "nominal" (cdr tree) :test #'equal))
|
|
|
|
|
|
|
|
;; —————————————————————————————————————
|
|
|
|
|
|
|
|
;; TREE_OF_VERB_PHRASE → CONS
|
|
|
|
(defun verb (tree)
|
|
|
|
(assoc "verb" (cdr tree) :test #'equal))
|
|
|
|
|
|
|
|
;; TREE_OF_NOUN_PHRASE → CONS
|
|
|
|
(defun prep (noun-phrase)
|
|
|
|
(assoc "prep" (cdr noun-phrase) :test #'equal))
|
|
|
|
|
|
|
|
;; TREE_OF_NOMINAL_PHRASE → STRING
|
|
|
|
(defun noun (nominal-phrase)
|
|
|
|
"Return the name of a noun's nominal phrase."
|
|
|
|
(cadr (assoc "noun" (cdr nominal-phrase) :test #'equal)))
|
|
|
|
|
|
|
|
;; TREE_OF_NOUN_PHRASE → STRING
|
|
|
|
(defun det (noun-phrase)
|
|
|
|
"Return a noun-phrase's det attr— 'the', 'a', 'this', etc."
|
|
|
|
(cadr (assoc "det" (cdr noun-phrase) :test #'equal)))
|
|
|
|
|
|
|
|
;; TREE_OF_NOUN_PHRASE → STRING
|
|
|
|
(defun proper-noun (noun-phrase)
|
|
|
|
"Return the proper noun of a noun-phrase."
|
|
|
|
(cadr (assoc "proper-noun" (cdr noun-phrase) :test #'equal)))
|
|
|
|
|
|
|
|
;; TREE_OF_NOUN_PHRASE → STRING
|
|
|
|
(defun noun-name (noun-phrase)
|
|
|
|
"Return the name of a noun, whether it's a proper noun or not."
|
|
|
|
(if (nominal noun-phrase)
|
|
|
|
(noun (nominal noun-phrase))
|
|
|
|
(proper-noun noun-phrase)))
|
|
|
|
|
|
|
|
;; —————————————————————————————————————
|
|
|
|
|
|
|
|
;; FULL_TREE → TREE_OF_VERB_PHRASE
|
|
|
|
(defun the-action (full-tree)
|
|
|
|
"Return THE main action of a sentence— takes the root of a statement's tree."
|
|
|
|
(verb-phrase full-tree))
|
|
|
|
|
|
|
|
;; FULL_TREE → TREE_OF_NOUN_PHRASE
|
|
|
|
(defun the-subject (full-tree)
|
|
|
|
"Return THE subject of a sentence— AKA, the first noun-phrase. Assumes
|
|
|
|
subject-verb-etc order."
|
|
|
|
(car (noun-phrases full-tree)))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; —————————————————————————————————————
|
|
|
|
;; X-IF.LEXICON
|
|
|
|
;; MANAGEMENT OF EARLEY-PARSER'S LEXICON
|
|
|
|
|
|
|
|
(in-package :x-if.lexicon)
|
|
|
|
|
|
|
|
;; —————————————————————————————————————
|
|
|
|
|
2020-01-14 23:46:57 -06:00
|
|
|
(defvar *string-lexicon*)
|
|
|
|
(setq *string-lexicon*
|
2020-01-10 17:19:45 -06:00
|
|
|
"the :class <det>
|
|
|
|
that :class <det>
|
|
|
|
this :class <det>
|
|
|
|
here :class <prep>
|
|
|
|
there :class <prep>
|
2020-01-14 23:46:57 -06:00
|
|
|
above :class <prep>
|
|
|
|
below :class <prep>
|
|
|
|
beside :class <prep>
|
|
|
|
across :class <prep>
|
2020-01-10 17:19:45 -06:00
|
|
|
be :class <aux>
|
|
|
|
to :class <prep>
|
|
|
|
with :class <prep>
|
|
|
|
a :class <det>
|
|
|
|
an :class <det>
|
|
|
|
")
|
|
|
|
|
2020-01-14 23:46:57 -06:00
|
|
|
(defvar *lexicon* nil)
|
|
|
|
|
|
|
|
|
|
|
|
;; STRING STRING → NIL
|
|
|
|
(defun add-word (word class)
|
|
|
|
"Add a word of the given class to the string-lexicon and parsed lexicon."
|
|
|
|
(setq *string-lexicon*
|
|
|
|
(concatenate 'string *string-lexicon*
|
|
|
|
(format nil "~A :class \<~A\>~%" word class)))
|
|
|
|
(reload-lexicon))
|
|
|
|
|
|
|
|
|
|
|
|
;; STRING → NIL
|
|
|
|
(defun remove-word (word)
|
|
|
|
"Remove a word from the string-lexicon and parsed lexicon."
|
|
|
|
(when (is-word-p word)
|
|
|
|
(setq *string-lexicon*
|
|
|
|
(xif.m:remove-line *string-lexicon* word
|
|
|
|
:test #'cl-strings:starts-with))
|
|
|
|
(reload-lexicon)))
|
|
|
|
|
|
|
|
;; STRING → BOOLEAN
|
|
|
|
(defun is-word-p (word)
|
|
|
|
"Return whether or not a given word is in the lexicon."
|
|
|
|
(xif.m:line-position *string-lexicon* word :test #'cl-strings:starts-with))
|
|
|
|
|
|
|
|
|
|
|
|
;; SYMBOL SYMBOL STRING → (DEFUN … )
|
|
|
|
(defmacro defun-add-wordclass (function-name class-symbol class-string)
|
|
|
|
"Define the add-WORD function of the given word-class. #'add-noun, etc."
|
|
|
|
`(defun ,function-name (,class-symbol)
|
|
|
|
,(format nil "Add a word of class ~A to the lexicon." class-string)
|
|
|
|
(add-word ,class-symbol ,class-string)))
|
|
|
|
|
|
|
|
(defun-add-wordclass add-proper-noun proper-noun "proper-noun")
|
|
|
|
(defun-add-wordclass add-noun noun "noun")
|
|
|
|
(defun-add-wordclass add-adjective adjective "adjective")
|
|
|
|
(defun-add-wordclass add-verb verb "verb")
|
|
|
|
|
|
|
|
|
|
|
|
;; GAME-OBJECT → NIL
|
|
|
|
(defmethod add-game-object-words ((object xif.e::game-object))
|
|
|
|
"Add a game-object's words (nouns, adjectives, proper-nouns) to the lexicon."
|
|
|
|
(mapcar #'add-adjective (xif.e:adjectives object))
|
|
|
|
(mapcar #'add-proper-noun (xif.e:proper-nouns object))
|
|
|
|
(mapcar #'add-noun (xif.e:nouns object)))
|
|
|
|
|
|
|
|
;; GAME-OBJECT → NIL
|
|
|
|
(defmethod remove-game-object-words ((object xif.e::game-object))
|
|
|
|
"Remove a game-object's words (nouns, adjectives, proper-nouns) to the lexicon."
|
|
|
|
(mapcar #'xif.l:remove-word (xif.e:nouns object))
|
|
|
|
(mapcar #'xif.l:remove-word (xif.e:proper-nouns object))
|
|
|
|
(mapcar #'xif.l:remove-word (xif.e:adjectives object)))
|
|
|
|
|
|
|
|
;; STRING → LEXICON
|
2020-01-10 17:19:45 -06:00
|
|
|
(defun load-string-lexicon (lex-string)
|
2020-01-14 23:46:57 -06:00
|
|
|
"Read all words from a dictionary file into a lexicon and a part of speech.
|
|
|
|
Abridged version of #'earley-parser:load-lexicon (which reads from a file)."
|
2020-01-10 17:19:45 -06:00
|
|
|
(with-input-from-string (lex-str-stream lex-string)
|
|
|
|
(let ((lexicon (make-hash-table :test earley-parser::*string-comparer*))
|
|
|
|
(part-of-speech nil))
|
|
|
|
(loop :while (listen lex-str-stream)
|
|
|
|
:do (let ((w (earley-parser::read-lexicon-line lex-str-stream)))
|
2020-01-14 23:46:57 -06:00
|
|
|
(pushnew (earley-parser::terminal-class w)
|
|
|
|
part-of-speech
|
|
|
|
:test earley-parser::*string-comparer*)
|
2020-01-10 17:19:45 -06:00
|
|
|
(push w (gethash (earley-parser::terminal-word w) lexicon))))
|
2020-01-14 23:46:57 -06:00
|
|
|
(earley-parser::make-lexicon :dictionary lexicon
|
|
|
|
:part-of-speech part-of-speech))))
|
2020-01-10 17:19:45 -06:00
|
|
|
|
2020-01-14 23:46:57 -06:00
|
|
|
;; NIL → NIL
|
2020-01-10 17:19:45 -06:00
|
|
|
(defun reload-lexicon ()
|
2020-01-14 23:46:57 -06:00
|
|
|
"Updates the lexicon by parsing the string-lexicon."
|
|
|
|
(setq *lexicon* (load-string-lexicon *string-lexicon*)))
|
|
|
|
|
|
|
|
|
|
|
|
|
2020-01-02 00:49:21 -06:00
|
|
|
|
|
|
|
;; —————————————————————————————————————
|
|
|
|
;; X-IF.INTERPRET
|
|
|
|
;; SENTENCE INTERPRETATION
|
|
|
|
|
|
|
|
(in-package :x-if.interpret)
|
|
|
|
|
|
|
|
;; —————————————————————————————————————
|
|
|
|
|
|
|
|
;; This package will take a parsed sentence (earley tree) and return proper
|
|
|
|
;; actions to be taken based on the sentence.
|
|
|
|
|
|
|
|
;; #'interpret will return either a list— of a function-name, followed by
|
|
|
|
;; x-if.environment objects with identifying symbols, or an error string with
|
|
|
|
;; symbol signifying the error as a second return-value.
|
|
|
|
|
|
|
|
;; The actionable list (function-name, followed by arguments to said function)
|
|
|
|
;; will look like this, for example:
|
|
|
|
;; '(#'kill :direct <XIF.E:MAN> :indirect <XIF.E:KNIFE> :subject <XIF.E:PLAYER>)
|
|
|
|
;; if you give it the sentence
|
|
|
|
;; "Kill the man with the knife."
|
|
|
|
;; … assuming that the knife is a valid object (in inventory or room) and the
|
|
|
|
;; man is is valid as well (in room or inventory).
|
|
|
|
|
|
|
|
;; If, for example, either the knife or man are invalid, an appropriate string
|
|
|
|
;; will be returned instead, to be printed as an error.
|
|
|
|
;; For instance: "you can't do that" or "that object isn't here", in cases
|
|
|
|
;; where the word is in lexicon but not currently applicable.
|
|
|
|
;; It will also return an appropriate error symbol, as a second value—
|
|
|
|
;; I.E., 'INVALID-ACTION, etc.
|
|
|
|
|
2020-01-14 23:46:57 -06:00
|
|
|
;; If a word *isn't* in lexicon, or something else crops up, then
|
|
|
|
;; #'x.if.parsing:parse will return an error symbol instead of a queued-action
|
|
|
|
;; object— which means that #'interpret will recieve that error symbol from the
|
|
|
|
;; engine. In this case, #'interpret will return the symbol as if it were its
|
|
|
|
;; own error-symbol, but with an error-symbol of 'PARSE-DIE.
|
|
|
|
;; If the error is in the interpretation method, it'll obviously return the
|
|
|
|
;; second error-symbol as 'INTERPRET-DIE.
|
2020-01-02 00:49:21 -06:00
|
|
|
|
|
|
|
;; Anyway, ultimately the engine will actually execute the actionable list
|
|
|
|
;; generated by #'interpret.
|
|
|
|
|
|
|
|
;; —————————————————————————————————————
|
|
|
|
|
2020-01-14 23:46:57 -06:00
|
|
|
;; TODO: Obviously, if there are multiple matches it should error TF out
|
|
|
|
;; and die, and... and... AHHHH good luck ;w;
|
|
|
|
|
|
|
|
;; TREE_OF_STATEMENT → LIST || (SYMBOL SYMBOL)
|
2020-01-02 00:49:21 -06:00
|
|
|
(defmethod interpret ((statement-tree list))
|
|
|
|
"Actually interpret a parsed statement-tree; returns a list with the
|
|
|
|
applicable function-name for the action, and the objects for the direct and
|
|
|
|
indirect objects, as well as the subject."
|
|
|
|
(let* ((subject (or (the-subject statement-tree) (xif.e:get-player)))
|
|
|
|
(action (the-action statement-tree))
|
|
|
|
(verb (verb action))
|
2020-01-14 23:46:57 -06:00
|
|
|
(indirect (xif.e:noun→game-objects (indirect-object action)))
|
|
|
|
(direct (xif.e:noun→game-objects (direct-object action))))
|
2020-01-02 00:49:21 -06:00
|
|
|
(cond ((not (xif.l:action-p verb))
|
|
|
|
"That… that's just not a thing people do.")
|
|
|
|
((and (not indirect) (xif.l:action-indirect-required-p verb))
|
|
|
|
(values "With what?" 'NO-INDIRECT))
|
|
|
|
((and (not direct) (xif.l:action-direct-required-p verb))
|
|
|
|
(values "To what?" 'NO-INDIRECT))
|
|
|
|
(T
|
|
|
|
(list (xif.l:action-function verb)
|
|
|
|
:subject subject :indirect indirect :direct direct)))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; —————————————————————————————————————
|
|
|
|
;; X-IF.ENVIRONMENT
|
2020-01-14 23:46:57 -06:00
|
|
|
;; OBJECTS, GAME-STATE, ETC.
|
2020-01-02 00:49:21 -06:00
|
|
|
|
|
|
|
(in-package :x-if.environment)
|
|
|
|
|
|
|
|
;; —————————————————————————————————————
|
|
|
|
|
2020-01-14 23:46:57 -06:00
|
|
|
;; This package contains all aspect of the actual game 'environment'—
|
|
|
|
;; all objects (rooms, entities, etc), means of accessing and modifying them,
|
|
|
|
;; etc.
|
2020-01-10 17:19:45 -06:00
|
|
|
|
2020-01-14 23:46:57 -06:00
|
|
|
;; There is a main overarching class (game-object), of which everything else is
|
|
|
|
;; derived. From there, there are two divering subclasses— the 'location'
|
2020-01-10 17:19:45 -06:00
|
|
|
|
2020-01-14 23:46:57 -06:00
|
|
|
;; —————————————————————————————————————
|
|
|
|
;; CLASSES
|
|
|
|
|
|
|
|
;; The overarching class
|
|
|
|
(define-persistent-class game-object ()
|
2020-01-02 00:49:21 -06:00
|
|
|
((id :read
|
|
|
|
:initarg :id :reader id
|
|
|
|
:index-type bknr.datastore::unique-index
|
|
|
|
:index-initargs (:test #'equal)
|
2020-01-14 23:46:57 -06:00
|
|
|
:index-reader id→game-object
|
|
|
|
:index-values all-game-objects)
|
|
|
|
(nouns :update
|
|
|
|
:initarg :nouns :reader nouns)
|
|
|
|
(proper-nouns :update
|
|
|
|
:initarg :proper-name :reader proper-nouns
|
2020-01-02 00:49:21 -06:00
|
|
|
:initform nil)
|
2020-01-14 23:46:57 -06:00
|
|
|
(adjectives :update
|
2020-01-02 00:49:21 -06:00
|
|
|
:initarg :adjectives :reader adjectives
|
|
|
|
:initform nil)
|
2020-01-14 23:46:57 -06:00
|
|
|
(description :update
|
2020-01-02 00:49:21 -06:00
|
|
|
:initarg :desc :reader description
|
2020-01-14 23:46:57 -06:00
|
|
|
:initform nil)
|
|
|
|
(parent :update
|
|
|
|
:initarg :parent :reader parent
|
|
|
|
:initform nil)
|
|
|
|
(children :update
|
|
|
|
:initarg :children :reader children
|
|
|
|
:initform nil)
|
|
|
|
(max-children :update
|
|
|
|
:initarg :max-children :reader max-children
|
2020-01-02 00:49:21 -06:00
|
|
|
:initform nil)))
|
|
|
|
|
2020-01-14 23:46:57 -06:00
|
|
|
;; For any object that can interacted with
|
|
|
|
(define-persistent-class entity (game-object)
|
|
|
|
((hp :update
|
2020-01-02 00:49:21 -06:00
|
|
|
:initarg :hp :reader hp
|
|
|
|
:initform nil)
|
2020-01-14 23:46:57 -06:00
|
|
|
(max-hp :update
|
2020-01-02 00:49:21 -06:00
|
|
|
:initarg :max-hp :reader max-hp
|
2020-01-14 23:46:57 -06:00
|
|
|
:initform nil)
|
|
|
|
(weight :update
|
|
|
|
:initarg :weight :reader weight
|
|
|
|
:initform 0)))
|
2020-01-02 00:49:21 -06:00
|
|
|
|
2020-01-14 23:46:57 -06:00
|
|
|
;; These classes only exist for indexing and semantic purposes;
|
|
|
|
;; they are identical to their super-classes
|
2020-01-02 00:49:21 -06:00
|
|
|
|
2020-01-14 23:46:57 -06:00
|
|
|
;; For NPCs, animals, etc.
|
|
|
|
(define-persistent-class mob (entity) ())
|
2020-01-02 00:49:21 -06:00
|
|
|
|
2020-01-14 23:46:57 -06:00
|
|
|
;; For the PLAYER.
|
|
|
|
(define-persistent-class player (mob) ())
|
2020-01-02 00:49:21 -06:00
|
|
|
|
2020-01-14 23:46:57 -06:00
|
|
|
;; For LOCATIONS (rooms and such).
|
|
|
|
(define-persistent-class location (game-object) ())
|
|
|
|
|
|
|
|
|
|
|
|
;; For hypothetical ACTIONS;
|
|
|
|
;; that is, commands the player can enter which will execute a given function.
|
2020-01-10 17:19:45 -06:00
|
|
|
(define-persistent-class action ()
|
2020-01-02 00:49:21 -06:00
|
|
|
((function-name :read
|
2020-01-10 17:19:45 -06:00
|
|
|
:initarg :function :reader function-name)
|
|
|
|
; :index-type bknr.datastore::hash-index
|
|
|
|
; :index-reader function→action
|
2020-01-02 00:49:21 -06:00
|
|
|
(verbs :read
|
|
|
|
:initarg :verbs :reader verbs)
|
2020-01-10 17:19:45 -06:00
|
|
|
; :index-type bknr.datastore::hash-index
|
|
|
|
; :index-reader verb→action
|
|
|
|
(direct-object-p :read
|
|
|
|
:initarg :direct-object-p :initform nil :reader direct-object-required-p)
|
|
|
|
(indirect-object-p :read
|
|
|
|
:initarg :indirect-object-p :initform nil :reader indirect-object-required-p)))
|
|
|
|
|
2020-01-14 23:46:57 -06:00
|
|
|
|
|
|
|
;; For tuŝeblaj ACTIONS; generated by :x-if.interpret from interpreting a user
|
|
|
|
;; statement. This is what will actually be executed by :x-if.interpret.
|
2020-01-10 17:19:45 -06:00
|
|
|
(defclass queued-action ()
|
|
|
|
((function-name
|
|
|
|
:initarg :function :accessor function-name)
|
|
|
|
(direct-object
|
|
|
|
:initarg :direct-object :initform nil :accessor direct-object)
|
|
|
|
(indirect-object
|
|
|
|
:initarg :indirect-object :initform nil :accessor indirect-object)
|
|
|
|
(subject
|
|
|
|
:initarg :subject :initform (get-player) :accessor subject)))
|
2020-01-02 00:49:21 -06:00
|
|
|
|
2020-01-14 23:46:57 -06:00
|
|
|
|
|
|
|
;; —————————————————
|
|
|
|
;; OBJECT ADD/DEL
|
|
|
|
|
|
|
|
;; These are here to appropriately modify the LEXICON (xif.l:*lexicon*)
|
|
|
|
;; according to objects in the game. Words used to describe objects
|
|
|
|
;; and actions will be added when an object is initialized; deleted
|
|
|
|
;; when destroyed.
|
|
|
|
|
|
|
|
;; TODO
|
|
|
|
;; Nuance is necessary; if a noun/adjective/etc is used for other objects,
|
|
|
|
;; it shouldn't be added again nor deleted from the lexicon when adding a new
|
|
|
|
;; object or deleting one, respectively.
|
|
|
|
;; For now, it's assumed all words are new, and are all used by one object.
|
|
|
|
|
|
|
|
(defmethod initialize-instance :after ((game-object game-object) &key)
|
|
|
|
(xif.l:add-game-object-words game-object))
|
|
|
|
|
|
|
|
(defmethod destroy-object :after ((game-object game-object) &key)
|
|
|
|
(xif.l:delete-game-object-words game-object))
|
2020-01-02 00:49:21 -06:00
|
|
|
|
|
|
|
|
2020-01-10 17:19:45 -06:00
|
|
|
|
|
|
|
(defmethod initialize-instance :after ((action action) &key)
|
2020-01-14 23:46:57 -06:00
|
|
|
(mapcar #'xif.l:add-verb (verbs action)))
|
|
|
|
|
|
|
|
;; TODO: write #'xif.l:remove-action
|
|
|
|
(defmethod destroy-object :after ((action action) &key))
|
|
|
|
|
|
|
|
|
|
|
|
;; —————————————————
|
|
|
|
;; PARENT/CHILD
|
|
|
|
|
|
|
|
;; GAME-OBJECT GAME-OBJECT → NIL
|
|
|
|
(deftransaction link (child parent)
|
|
|
|
"Link two objects together, as child and parent."
|
|
|
|
(setf (slot-value parent 'children)
|
|
|
|
(nconc (slot-value parent 'children) (list child)))
|
|
|
|
;; --
|
|
|
|
(if (child-p child) (unlink child))
|
|
|
|
(setf (slot-value child 'parent) parent))
|
|
|
|
|
|
|
|
;; GAME-OBJECT → NIL
|
|
|
|
(deftransaction unlink (child)
|
|
|
|
"Seperate a child from it's parent (and vice-versa)."
|
|
|
|
(let ((parent (slot-value child 'parent)))
|
|
|
|
(setf (slot-value parent 'children)
|
|
|
|
(delete child (slot-value parent 'children)))
|
|
|
|
;; --
|
|
|
|
(setf (slot-value child 'parent) nil)))
|
|
|
|
|
|
|
|
|
|
|
|
;; GAME-OBJECT → BOOLEAN
|
|
|
|
(defmethod parent-p ((object game-object))
|
|
|
|
"Return whether or not an object is a parent (has 1+ children)."
|
|
|
|
(slot-value object 'children))
|
|
|
|
|
|
|
|
;; GAME-OBJECT → BOOLEAN
|
|
|
|
(defmethod child-p ((object game-object))
|
|
|
|
"Return whether or not an object is a child (has a parent)."
|
|
|
|
(slot-value object 'parent))
|
|
|
|
|
|
|
|
|
|
|
|
;; —————————————————
|
|
|
|
;; INDEXING
|
|
|
|
|
|
|
|
;; NIL → PLAYER
|
|
|
|
(defun get-player ()
|
|
|
|
"Return the player object."
|
|
|
|
(car (store-objects-with-class 'player)))
|
|
|
|
|
|
|
|
;; NIL → LIST_OF_LOCATIONS
|
|
|
|
(defun all-locations ()
|
|
|
|
"Get all location objects."
|
|
|
|
(store-objects-with-class 'location))
|
|
|
|
|
|
|
|
;; NIL → LIST_OF_MOBS
|
|
|
|
(defun all-mobs ()
|
|
|
|
"Get all mob objects."
|
|
|
|
(store-objects-with-class 'mob))
|
|
|
|
|
|
|
|
;; NIL → LIST_OF_ENTITIES
|
|
|
|
(defun all-entities ()
|
|
|
|
"Get all entity objects."
|
|
|
|
(store-objects-with-class 'entity))
|
|
|
|
|
|
|
|
;; NIL → LIST_OF_ENTITIES
|
|
|
|
(defun all-actions ()
|
|
|
|
"Get all entity objects."
|
|
|
|
(store-objects-with-class 'action))
|
|
|
|
|
|
|
|
|
|
|
|
;; LIST_OF_OBJECTS STRING → LIST_OF_OBJECTS
|
|
|
|
(defun noun→objects (objects noun)
|
|
|
|
"Return objects within the current list of objects of the given noun."
|
|
|
|
(index-by-slot-list objects 'nouns noun))
|
|
|
|
|
|
|
|
;; LIST_OF_OBJECTS STRING → LIST_OF_OBJECTS
|
|
|
|
(defun adjective→objects (objects adjective)
|
|
|
|
"Return objects within the current list of objects of the given adjective."
|
|
|
|
(index-by-slot-list objects 'adjectives adjective))
|
|
|
|
|
|
|
|
;; LIST_OF_OBJECTS STRING → LIST_OF_OBJECTS
|
|
|
|
(defun proper-noun→objects (objects proper-noun)
|
|
|
|
"Return objects within the current list of objects of the given proper-noun"
|
|
|
|
(index-by-slot-list objects 'proper-nouns proper-noun))
|
|
|
|
|
|
|
|
;; STRING → LIST_OF_ACTIONS
|
|
|
|
(defun verb→actions (verb)
|
|
|
|
"Return all actions matching the given verb."
|
|
|
|
(index-by-slot-list (all-actions) 'verbs verb))
|
|
|
|
|
|
|
|
|
|
|
|
;; SYMBOL SYMBOL FUNCTION SYMBOL FUNCTION → (DEFUN …)
|
|
|
|
(defmacro defun-obj-word-index (name obj-type all-obj-type word-type word-fun)
|
|
|
|
"Makes an index function for the given object type and word-type.
|
|
|
|
I.E., will generate #'adjective→mobs for object-type 'mobs' and word-type of
|
|
|
|
'adjective'"
|
|
|
|
`(defun ,name (,word-type)
|
|
|
|
,(format nil "Return the ~A corresponding with the given ~A."
|
|
|
|
obj-type word-type)
|
|
|
|
(funcall ,word-fun (funcall ,all-obj-type) ,word-type)))
|
|
|
|
|
|
|
|
;; SYMBOL FUNCTION SYMBOL SYMBOL SYMBOL → ( (DEFUN …) (DEFUN …) (DEFUN …))
|
|
|
|
(defmacro defuns-obj-word-indices (obj-type all-obj adj→obj noun→obj pnoun→obj)
|
|
|
|
"Makes the index functions for a given object type for every word type.
|
|
|
|
I.E., when given 'mobs', it'll make #'noun→mobs, #'adjective→mobs, etc."
|
|
|
|
`(progn
|
|
|
|
(defun-obj-word-index ,adj→obj ,obj-type ,all-obj adjective
|
|
|
|
#'adjective→objects)
|
|
|
|
(defun-obj-word-index ,noun→obj ,obj-type ,all-obj noun #'noun→objects)
|
|
|
|
(defun-obj-word-index ,pnoun→obj ,obj-type ,all-obj proper-noun
|
|
|
|
#'proper-noun→objects)))
|
|
|
|
|
|
|
|
|
|
|
|
(defuns-obj-word-indices game-object #'all-game-objects
|
|
|
|
adjective→game-objects noun→game-objects proper-noun→game-objects)
|
|
|
|
(defuns-obj-word-indices entity #'all-entities
|
|
|
|
adjective→entities noun→entities proper-noun→entities)
|
|
|
|
(defuns-obj-word-indices mob #'all-mobs
|
|
|
|
adjective→mobs noun→mobs proper-noun→mobs)
|
|
|
|
(defuns-obj-word-indices locations #'all-locations
|
|
|
|
adjective→locations noun→locations proper-noun→locations)
|
|
|
|
|
|
|
|
|
|
|
|
;; LIST_OF_OBJECTS SYMBOL VARYING → LIST_OF_OBJECTS
|
|
|
|
(defun index-by-slot-list (objects slot-name target)
|
|
|
|
"Return objects from the given list that contain a target item in the list
|
|
|
|
of the given slot."
|
|
|
|
(index-by-slot objects slot-name target :test #'xif.m:position-equal))
|
|
|
|
|
|
|
|
;; LIST_OF_OBJECTS SYMBOL VARYING :FUNCTION → LIST_OF_OBJECTS
|
|
|
|
(defun index-by-slot (objects slot-name target &key (test #'equal))
|
|
|
|
"Return objects from the given list that pass the given test between
|
|
|
|
slot-value and target."
|
|
|
|
(loop :for object :in objects
|
|
|
|
:if (funcall test target (slot-value object slot-name))
|
|
|
|
:collect object))
|
|
|
|
|
|
|
|
|
2020-01-02 00:49:21 -06:00
|
|
|
|
|
|
|
|
|
|
|
;; —————————————————————————————————————
|
|
|
|
;; X-IF.CLIENT
|
2020-01-14 23:46:57 -06:00
|
|
|
;; ACTUALLY PLAY THE GAME
|
2020-01-02 00:49:21 -06:00
|
|
|
|
|
|
|
(in-package :x-if.client)
|
|
|
|
|
|
|
|
;; —————————————————————————————————————
|
|
|
|
|
|
|
|
;; This is the general client package— everything else uses it.
|
|
|
|
|
|
|
|
;; —————————————————————————————————————
|
|
|
|
|
|
|
|
(defun status ()
|
2020-01-14 23:46:57 -06:00
|
|
|
(format nil "~A~%" (slot-value (get-player) 'xif.e::parent)))
|
2020-01-02 00:49:21 -06:00
|
|
|
|
|
|
|
(defun prompt () ">> ")
|
|
|
|
|
|
|
|
(defun game-loop ()
|
|
|
|
(let ((m 1))
|
|
|
|
(display-status)
|
|
|
|
(setq m (input-sentence))
|
|
|
|
(text "You said: ~A~%" m)
|
2020-01-14 23:46:57 -06:00
|
|
|
(text "~A~%" (xif.e:all-game-objects))
|
2020-01-02 00:49:21 -06:00
|
|
|
(text "I LOVE YOU~%")
|
|
|
|
(sleep 2)
|
|
|
|
(game-loop)))
|
|
|
|
|
|
|
|
(defun start (game)
|
|
|
|
(make-instance 'mp-store :directory #p"~/.local/share/x-if/"
|
|
|
|
:subsystems (list (make-instance 'store-object-subsystem)))
|
2020-01-14 23:46:57 -06:00
|
|
|
(if (not (all-game-objects))
|
2020-01-02 00:49:21 -06:00
|
|
|
(populate-world))
|
|
|
|
(game-loop))
|
|
|
|
|
2020-01-10 17:19:45 -06:00
|
|
|
(defun examine (object)
|
|
|
|
(text (xif.e:description object)))
|
|
|
|
|
2020-01-02 00:49:21 -06:00
|
|
|
(defun populate-world ()
|
2020-01-14 23:46:57 -06:00
|
|
|
(make-instance 'xif.e::location :id 0 :proper-nouns '("Lobby")
|
|
|
|
:nouns '("room")
|
|
|
|
:adjectives '("ugly")
|
2020-01-02 00:49:21 -06:00
|
|
|
:description "It's rather ugly, really.")
|
2020-01-14 23:46:57 -06:00
|
|
|
|
|
|
|
(make-instance 'xif.e::mob :id 101 :proper-nouns '("Barry")
|
|
|
|
:nouns '("human" "person" "man" "gentleman" "sir" "dude")
|
|
|
|
:adjectives '("suspicious")
|
|
|
|
:description "He looks suspicious, no?")
|
|
|
|
|
|
|
|
(make-instance 'xif.e::player :id 100
|
|
|
|
:proper-nouns '("Maria" "I" "myself" "me")
|
|
|
|
:nouns '("human" "person" "woman" "lady" "lass" "dudette")
|
|
|
|
:adjectives '("hideous")
|
|
|
|
:description "A rather hideous lass.")
|
|
|
|
|
2020-01-10 17:19:45 -06:00
|
|
|
(make-instance 'xif.e::action :function-name 'xif.c::examine :direct-object-p T
|
2020-01-14 23:46:57 -06:00
|
|
|
:verbs '("examine" "look" "view"))
|
|
|
|
|
|
|
|
(link (get-player) (id→game-object 0))
|
|
|
|
(link (id→game-object 100) (id→game-object 0)))
|
2020-01-02 00:49:21 -06:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; —————————————————————————————————————
|
|
|
|
;; X-IF.CLIENT.TERMINAL
|
2020-01-14 23:46:57 -06:00
|
|
|
;; A SIMPLE CLIENT
|
2020-01-02 00:49:21 -06:00
|
|
|
|
|
|
|
(in-package :x-if.client.terminal)
|
|
|
|
|
|
|
|
;; —————————————————————————————————————
|
|
|
|
|
|
|
|
;; This package is a client package— it uses only basic terminal input/output,
|
|
|
|
;; so ought to be the most portable possible. No image or music support.
|
|
|
|
|
|
|
|
;; —————————————————————————————————————
|
|
|
|
|
|
|
|
(defun xif.c::text (string &rest format-args)
|
|
|
|
(apply #'format (nconc (list t string) format-args)))
|
|
|
|
|
|
|
|
(defun xif.c::input-sentence ()
|
|
|
|
(read-line))
|
2020-01-10 17:19:45 -06:00
|
|
|
|
2020-01-14 23:46:57 -06:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; —————————————————————————————————————
|
|
|
|
;; X-IF.MISC
|
|
|
|
;; MISC HELPER FUNCTIONS
|
|
|
|
|
2020-01-10 17:19:45 -06:00
|
|
|
(in-package :x-if.misc)
|
|
|
|
|
2020-01-14 23:46:57 -06:00
|
|
|
;; —————————————————————————————————————
|
|
|
|
|
|
|
|
;; This package just contains random, useful functions that're used throughout
|
|
|
|
;; x-if. Mainly they're for string manipulations, etc.
|
|
|
|
|
|
|
|
;; STRING → LIST_OF_STRINGS
|
2020-01-10 17:19:45 -06:00
|
|
|
(defun string-lines (string)
|
2020-01-14 23:46:57 -06:00
|
|
|
"Turn a multi-line string into a list of lines."
|
2020-01-10 17:19:45 -06:00
|
|
|
(cl-strings:split string #\newline))
|
|
|
|
|
2020-01-14 23:46:57 -06:00
|
|
|
;; LIST_OF_STRINGS → STRING
|
|
|
|
(defun lines-string (lines)
|
|
|
|
"Turn a list of strings into a multi-lined string, with each string being
|
|
|
|
a seperate line."
|
|
|
|
(cl-strings:join lines :separator "
|
|
|
|
"))
|
|
|
|
|
|
|
|
|
|
|
|
;; STRING → STRING
|
|
|
|
(defmethod line-cdr ((string string))
|
|
|
|
"Get the 'cdr' of a multi-lined string (pop off the first line)."
|
|
|
|
(line-cdr (string-lines string)))
|
|
|
|
|
|
|
|
;; LIST_OF_STRINGS → STRING
|
|
|
|
(defmethod line-cdr ((lines list))
|
|
|
|
"Get the 'cdr' of a list of lines, then turn back into a string."
|
|
|
|
(lines-string (cdr lines)))
|
|
|
|
|
|
|
|
;; STRING → STRING
|
|
|
|
(defmethod line-car ((string string))
|
|
|
|
"Get a multi-lined string's 'car' (the first line)."
|
|
|
|
(line-car (string-lines string)))
|
2020-01-10 17:19:45 -06:00
|
|
|
|
2020-01-14 23:46:57 -06:00
|
|
|
;; LIST_OF_STRINGS → STRING
|
|
|
|
(defmethod line-car ((lines list))
|
|
|
|
"Get the 'car' of a list of lines."
|
|
|
|
(car lines))
|
2020-01-10 17:19:45 -06:00
|
|
|
|
2020-01-14 23:46:57 -06:00
|
|
|
|
|
|
|
;; STRING → NUMBER
|
2020-01-10 17:19:45 -06:00
|
|
|
(defun line-length (string)
|
2020-01-14 23:46:57 -06:00
|
|
|
"Return the amount of lines in a given string."
|
2020-01-10 17:19:45 -06:00
|
|
|
(length (string-lines string)))
|
|
|
|
|
2020-01-14 23:46:57 -06:00
|
|
|
;; STRING STRING FUNCTION → NUMBER
|
|
|
|
(defmethod line-position ((string string) target &key (test #'in-string-p))
|
|
|
|
"Return the number of the line in which a given target-string can be found,
|
|
|
|
within a multi-lined string."
|
|
|
|
(line-position (string-lines string) target :test test))
|
|
|
|
|
|
|
|
;; LIST_OF_STRINGS STRING FUNCTION → NUMBER
|
|
|
|
(defmethod line-position ((lines list) target &key (test #'in-string-p))
|
|
|
|
"Return which number string the given target-string can be found in."
|
|
|
|
(position T (mapcar (lambda (line) (funcall test line target)) lines)))
|
|
|
|
|
|
|
|
;; STRING STRING → BOOLEAN
|
|
|
|
(defun in-string-p (string target)
|
|
|
|
"Return whether or not a target-string is within another string."
|
|
|
|
(< 1 (length (cl-strings:split string target))))
|
|
|
|
|
|
|
|
;; STRING STRING FUNCTION → STRING
|
|
|
|
(defmethod remove-line ((string string) target &key (test #'in-string-p))
|
|
|
|
"Remove a line matching the given test, given a target string."
|
|
|
|
(remove-line (string-lines string) target :test test))
|
|
|
|
|
|
|
|
;; LIST_OF_STRINGS STRING FUNCTION → STRING
|
|
|
|
(defmethod remove-line ((lines list) target &key (test #'in-string-p))
|
|
|
|
"Remove a line matching the test, return a multi-lined string based on
|
|
|
|
given list, but sans that removed line, ofc."
|
|
|
|
(aif (ignore-errors (line-position lines target :test test))
|
|
|
|
(lines-string
|
|
|
|
(remove (nth it lines) lines :test #'equal :count 1))
|
|
|
|
(lines-string list)))
|
|
|
|
|
|
|
|
;; ITEM LIST → NUMBER
|
|
|
|
(defun position-equal (item list)
|
|
|
|
"Literally just #'cl:position but with the test equal."
|
|
|
|
(position item list :test #'equal))
|