And here comes the next chatbot, commented an “empty” (to “educate” all by yourself) and uncommented yet “pre-chatted” to immediately allow interaction. This system learns your replies and tries to mirror them to you when proper. Moreover, it tries to establish what “topics” the conversation presently follows. To adjust its behaviour, modify the function “sim”.
; Fathoming Ontology Xenodoch
; by Nino Ivanov, September 2019
; governed by Gnu Affero GPL v.3.0
; https://www.gnu.org/licenses/agpl-3.0.en.html
; This system is based on the idea that, upon input of a list by
; the user, the program should respond to the user in such a way
; as the user would have responded had he received a similar input
; in the past. This is accomplished by saving all exchanges, i.e.
; all user input and machine replies, in a "knowledge list", and
; then, upon receiving a new "challenge" by the user, seek as a
; "reply" some prior user-reply in a similar "situation".
; Intelligence is somewhat increased by using SEVERAL exchanges
; to describe the present situation, and not merely the last
; thing the user said, as well as using "topics", rare and recently
; used words - this should aid the "aptness" of the system reply.
; SAMPLE RUN - EVERY REPLY TAKES SEVERAL MINUTES TO PRODUCE:
; (run)
; READ----(well now you have been adjusted to your new environment I am
; curious how do you now feel)
; REPLY---(143 one must be careful whom one loves)
; INTERACTION----253--------------------CONFIDENCE----22.0014
; READ----(it is indeed advisable to be nice to one s overlord do you
; not think so)
; REPLY---(153 but there AM-ARE some things me will not quite be able
; to tell which you may find puzzling for instance me do not
; really care about having a name)
; INTERACTION----254--------------------CONFIDENCE----13.087
;
; whereby INTERACTION points to how many exchanges have been done
; and CONFIDENCE offers a peek at how certain the system is of the
; answer whereby values closer to 10 mean rather uncertain and
; values above 20 mean extremely certain.
; If you start from zero, then the first twenty or fourty inputs or so
; you will either get no reply or very shallow replies. This is normal.
; up to how many words will be counted as topics:
(defvar *maxtopics* 12)
; that part of the discussion that is regarded as
; the "most recent present", being worthy of reply
(defvar *seclen* 6) ; even and maximum as long as *most-recent* below
; the most recent part of the discussion that should not yet be used
; as part of any reply, for the risk of appearing repetitive (dumb)
(defvar *most-recent* '(() () () () () () () () () () () ()))
; the input
(defvar *in* '())
; the output
(defvar *out* '())
; the topics of interest: these are "rare words", i.e. such which
; have been used LATELY, but which have not been used a long time ago
; (at the beginning of knowledge, where the "oldest" knowledge resides)
(defvar *topics* '())
; temporary variable:
; section of knowledge to compare to most recent history
(defvar *new-sec* '())
; temporary variable:
; how well does a series of experienced chats match the present
(defvar *new-val* -1)
; temporary variable:
; the reply that the system presently considers
(defvar *cand* '())
; temporary variable:
; "how well" does the history, which leads to the reply, match the
(defvar *val* -1)
; "the present" - the most recent part of discussion; this is not only
; the last thing the user told, but also the few exchanges before that
(defvar *present* '())
; the knowledge: originally a list of nils, proposing NO replies for a
; while until the system has accumulated enough responses by the user
; to start replying him
(defvar *knowledge* '(
() () () () () () () () () () () () () () () () () () () () () () () ()
() () () () () () () () () () () () () () () () () () () () () () () ()
() () () () () () () () () () () () () () () () () () () () () () () ()
() () () () () () () () () () () () () () () () () () () () () () () ()
() () () () () () () () () () () () () () () () () () () () () () () ()
() () () () () () () () () () () () () () () () () () () () () () () ()
() () () () () () () () () () () () () () () () () () () () () () () ()
() () () () () () () () () () () () () () () () () () () () () () () ()
() () () () () () () () () () () () () () () () () () () () () () () ()
() () () () () () () () () () () () () () () () () () () () () () () ()
))
; temporary variable:
; simply, a copy of the knowledge later on
(defvar *new-knowledge* '())
; temporary variable
(defvar *cdr-most-recent* '())
; nth-cdr
(defun ncr (n lis)
(loop
(cond ((null lis) (return '()))
((zerop n) (return lis)))
(pop lis)
(decf n)))
; auxiliary for tkf
(defun proto-tkf (n lis res)
(loop
(cond ((or (zerop n) (null lis)) (return res)))
(setq res (append res (list (car lis))))
(pop lis)
(decf n)))
; take the first number of elements of a list
(defun tkf (n lis) (proto-tkf n lis '()))
; take the last number of elements of a list
(defun tkl (n lis)
(loop
(cond ((null (ncr n lis)) (return lis)))
(pop lis)))
; something like equal - because eq does not match lists
(defun ek (a b)
(cond ((eq a b) t)
((and (listp a) (listp b))
(cond ((or (null a) (null b)) '())
((not (ek (car a) (car b))) '())
(t (ek (cdr a) (cdr b)))))
(t '())))
; auxiliary for b-l
(defun pbl (lis res)
(loop
(cond ((null (cdr lis)) (return res)))
(setq res (append res (list (car lis))))
(pop lis)))
; butlast
(defun b-l (lis) (pbl lis '()))
; like "member", yet matching not with eq, but with ek
(defun mmb (el lis)
(loop
(cond ((null lis) (return '()))
((ek el (car lis)) (return lis)))
(pop lis)))
; make that a list does not begin with NILs
(defun e-n (lis)
(loop
(cond ((null lis) (return '()))
((not (null (car lis))) (return lis)))
(pop lis)))
; delete all instances of an element from a list
; this is the "flat" version - make eq to ek if
; you ever need the element to be itself a list
(defun dai (el lis)
(cond ((null lis) '())
((eq (car lis) el) (dai el (cdr lis)))
(t (cons (car lis) (dai el (cdr lis))))))
; make unique - each element in a list shall appear only once
; (recording the FIRST (not: the LAST) time an element is seen)
(defun muq (lis)
(cond ((null lis) '())
(t (cons (car lis) (muq (dai (car lis) (cdr lis)))))))
; (muq '(A B C A D B F C R B)) --> (A B C D F R)
; proto define topics - total between 0 and *maxtopics*
; remove any word that has been seen long ago from the
; present, if it can be found there, until only a few words
; of the present remain - these must be the "topics" of discussion
(defun ptx (lis kno)
(cond ((null (ncr *maxtopics* lis)) lis) ; list reduced to topics
((null kno) (tkl *maxtopics* lis)) ; can't reduce: take most recent
; end of the list
; (could be tkf instead, for a
; "more intuitive" approach)
((member (car kno) lis) ; i.e. assume it is usual
; blabla and eliminate it
(ptx (dai (car kno) lis) (cdr kno)))
(t (ptx lis (cdr kno)))))
; really, give the topics
(defun tpx (lis kno) (ptx (muq (dai '() lis)) kno))
; (tpx '(A B F L X C A B C D Y Y A C)
; '(F G R A L T D M G X R N M G B A Y C M))
; -->
; (B X C D Y)
(defun sqr (x) (* x x))
; turn a list into bi-grams - useful for comparing phrases
(defun frg (lis)
(mapcar 'list (b-l lis) (cdr lis)))
; (frg '(A B C D E)) --> ((A B) (B C) (C D) (D E))
; match-elements
; count how many times - with repetitions - an element of
; one list is seen within the other list.
; ASUMMETRIC
(defun proto-match-elements (l1 l2)
(cond ((null l1) 0)
((mmb (car l1) l2) (+ 1 (proto-match-elements (cdr l1) l2)))
(t (proto-match-elements (cdr l1) l2))))
; make the matching of elements symmetric, i.e. l1 l2 = l2 l1
(defun match-elements (l1 l2)
(+ (proto-match-elements l1 l2) (proto-match-elements l2 l1)))
; (match-elements '(A R C C C B) '(A B C C D)) --> 9
; the similarity of two lists-of-lists, each like ((A B) (C D E F) (G))
; - this is to match "the present situation" (the last few exchanges)
; to "some historic situation" (the few exchanges that happened then)
; and "continue according to how then the human user has continued"
(defun sim (ll1 ll2) ; ll1 will be the present, ll2 the knowledge seciton
(cond ((null ll1) 0)
; penalise tendencies for full repetition, i.e. force variation:
((mmb (car ll2) *cdr-most-recent*) (sim (cdr ll1) (cdr ll2)))
(t (+
(/ (+ 10
(match-elements (car ll1) (car ll2))
(* 2.0 (match-elements (frg (car ll1)) (frg (car ll2))))
(* 4.0 (match-elements (car ll2) *topics*)))
(+ 10 (abs (- (length (car ll1)) (length (car ll2))))))
(* 1.25
(sim (cdr ll1) (cdr ll2)))))))
; force matching, otherwise lists are set to match nil,
; and that leads to some rather stupid results:
; without this ((A B C) NIL (D E F) NIL) and
; (NIL (A B C) NIL (D E F)) yield NIL, as you are
; comparing against the empty list - and the system
; cannot learn without any previous knowledge, which
; is, however, exactly what it should be able to do
(defun fill-gaps (lis)
(cond ((null lis) '())
((null (cdr lis)) lis)
((and (null (car lis)) (not (null (cadr lis))))
(cons (cadr lis) (cons (cadr lis) (fill-gaps (cddr lis)))))
(t (cons (car lis) (fill-gaps (cdr lis))))))
; setup instincts
; this is to "mirror" the system's replies better to the user
(defun word-instinct (word)
(cond ((eq word 'I) 'YOU)
((eq word 'ME) 'YOU)
((eq word 'YOU) 'ME)
((eq word 'AM) 'ARE)
((eq word 'ARE) 'AM-ARE)
((eq word 'MINE) 'YOURS)
((eq word 'YOURS) 'MINE)
((eq word 'MY) 'YOUR)
((eq word 'YOUR) 'MY)
((eq word 'MYSELF) 'YOURSELF)
((eq word 'YOURSELF) 'MYSELF)
((eq word 'WAS) 'WAS-WERE)
(t word)))
(defun proto-apply-instincts (sentence checked-sentence)
(cond ((null sentence)
(reverse checked-sentence))
(t
(proto-apply-instincts
(cdr sentence)
(cons (word-instinct (car sentence)) checked-sentence)))))
(defun apply-instincts (sentence)
(proto-apply-instincts sentence '()))
; sample call: (apply-instincts '(I WAS HERE TODAY))
; --> (YOU WAS-WERE HERE TODAY)
; a counter of the replies which only grows - for better tracking
; where the responses come from
(defvar *c* 0)
; the main loop
(defun run ()
(loop
; read user input - a list of symbols
(setq *in* (progn (princ 'READ----) (read)))
; terminate if the user entered nothing - you can now
; "collect" the accumulated knowledge and most recent history
(cond ((null *in*) (return '())))
; set counter
(push (incf *c*) *in*)
; shorten the knowledge - by two elements, challenge and reply
(pop *knowledge*)
(pop *knowledge*)
; update the knowledge with the previous challenge-reply pair
(setq *knowledge* (append *knowledge* (list (car *most-recent*)
(cadr *most-recent*))))
; shorten the list of most recent exchanges, to make space for a
; new challenge-reply-pair
(pop *most-recent*)
(pop *most-recent*)
(setq *most-recent* (append *most-recent* (list *out*) (list *in*)))
(setq *cdr-most-recent* (mapcar 'cdr *most-recent*))
; prepare the present - this is the most recent discussion,
; but nil-replies by the system are disregarded (there are none by
; the user, as that would have ended interaction)
(setq *present* (mapcar 'cdr (fill-gaps (tkl *seclen* *most-recent*))))
; filter the topics of discussion, which words "matter more"
(setq *topics*
(tpx (apply 'append *cdr-most-recent*)
(apply 'append (tkf 100 (mapcar 'cdr (e-n *knowledge*))))))
; now, take a section of knowledge, and compare these exchanges
; within this taken section to the "present" - those which match
; it the best must be the ones that best describe "our present
; situation"; then, shift by one exchange (i.e. two lists, one for
; the user's answer and one for the machine's reply), and see
; whether a section of knowledge from there might provide even more
; fitting experience to the present
(setq *cand* '())
(setq *val* -1)
(setq *out*
(loop
(push (pop *knowledge*) *new-knowledge*) ; this makes sure we
; adjust knowledge in the beginning so that the answer will be
; the next human answer known to the system
(cond ((null (ncr *seclen* *knowledge*)) (return *cand*)))
(setq *new-sec* (mapcar 'cdr (tkf *seclen* *knowledge*)))
(setq *new-val* (sim *present* *new-sec*))
(cond ((and (> *new-val* *val*)
(not (mmb (cdar (ncr *seclen* *knowledge*))
*cdr-most-recent*)))
(progn (setq *val* *new-val*)
(setq *cand* (car (ncr *seclen* *knowledge*))))))
(push (pop *knowledge*) *new-knowledge*)))
; and now "re-wind" the knowledge so new-knowledge is empty again and
; all knowledge is contained in *knowledge*, thus preparing for the
; next reply:
(loop
(cond ((null *new-knowledge*) (return '())))
(push (pop *new-knowledge*) *knowledge*))
(terpri)
(princ 'REPLY---)
; instinct adjustment is ephemeral, i.e. not learned:
(princ (apply-instincts *out*))
(terpri)
(princ 'INTERACTION----)(princ *c*)
(princ '--------------------)
(princ 'CONFIDENCE----) (princ *val*)
(terpri)))