OK, this will be long and messy, I just quickly want to dump it off and may edit my post later, but maybe it will be useful “as is”. So I am have written an AI and I am trying to port it to ulisp.
The original code, in the relevant part, looks like this:
; This is an extremely simplified
; "logical triangulation system" (a general type of symbolic
; AI I invented, and of the "directional" variety: the
; structures AB & BA may BOTH exist and are OPPOSITE).
; How it works: it is based on the idea that it
; (i) RECOGNISES symbolic structures as seen already and
; (ii) tries to CONTINUE the recognised structures
; with other structures according to its observations.
; If structures are unknown, it tries to guess the new
; structures according to delimiters.
; Structures are remembered based on "priority" (most
; recently used or hypothetised ones get high priority)
; and thus a sort of "evolution" ensues which makes
; certain that the system remembers, in the end, only
; the "most useful" or the "most recent" structures.
; "More often seen" structures and structural delimiters
; will thus survive longer and cause future structural
; recognition to be based on them - and thus, they control
; the corresponding action, too. This is how the system,
; over time, "strives to become more intelligent".
; "New" structures are guessed in their delimitations
; according to which symbols already served as
; delimitations in known structures, that is some known
; (A B) proposes (A... and ...B) as delimiters, so
; the system can guess e.g. some (A X) or some (Q B).
; This evolution happens in the "knowledge", the program's
; "long term memory". - A "short term memory" is the
; "history", which serves as a verbatim store of the
; most recently perceived symbols - here, there is no
; evolution and symbols simply enter and are forgotten
; "FIFO-style".
; Usage: after loading the Common Lisp file, simply type
; (run)
; and press Enter. Then, upon receiving the input prompt,
; you can write sentences in form of lists of symbols,
; e.g. (HELLO HOW ARE YOU TODAY).
; Initially, you will receive only an empty reply, i.e.
; the machine has not yet learned how to answer you.
; After a while - and in particular if you keep your
; variety of symbols used as low as you can - you will
; begin to receive materially relevant replies.
; To gain some awareness of "what happens", you will
; see above the received reply also the present state
; of the history and of the evolved stage of the knowledge.
; Receiving a reply may take a very long time - this is
; normal.
; The system also employs projections of history into the
; future prior to "actually" evaluting the user's reply
; and giving an answer: this is a form of "daydreaming"
; or "hypothetising", the way described in prior AI
; research, with the aim of making the system aware of a
; greater count of "possible" - even if not actually
; observed - arrangements of input.
; sample interaction:
; * (run)
; READ----(hello machine how are you)
;
; (TOP-NEW-KNOWLEDGE
; (((MACHINE SO) ((YOU DO) OPERATE))
; ((TRM HELLO) (((MACHINE HOW) ARE) (YOU TRM))))
; ((MACHINE SO) ((YOU DO) OPERATE))
; ((TRM HELLO) (((MACHINE HOW) ARE) (YOU TRM))) (((MACHINE HOW) ARE) (YOU TRM))
; ((MACHINE HOW) ARE) (MACHINE HOW) (MACHINE SO) ((YOU DO) OPERATE) (YOU TRM)
; (YOU DO) (TRM HELLO)
; ((((MY DEAR) (MACHINE TRM)) (WELL (MACHINE SO)))
; ((YOU DO) ((OPERATE TRM) HELLO)))
; (((MY DEAR) (MACHINE TRM)) (WELL (MACHINE SO)))
; ((YOU DO) ((OPERATE TRM) HELLO)) ((OPERATE TRM) HELLO)
; ((MY DEAR) (MACHINE TRM)) (WELL (MACHINE SO)) (MY DEAR) (OPERATE TRM)
; (MACHINE TRM))
;
; (NEW-HISTORY HELLO MACHINE HOW ARE YOU TODAY MY DEAR MACHINE TRM WELL MACHINE
; SO YOU DO OPERATE TRM HELLO MACHINE HOW ARE YOU TRM HELLO MACHINE HOW ARE YOU
; TODAY MY DEAR MACHINE TRM)
;
; (REPLY-- HELLO MACHINE HOW AM-ARE ME TODAY YOUR DEAR MACHINE)
; generate lists of a desired symbol and length
(defun proto-gen-sym (n sym lis)
(loop
(cond ((zerop n) (return lis)))
(push sym lis)
(decf n)))
(defun gen-sym (n sym) (proto-gen-sym n sym '()))
; up to what chunk of symbols can be processed at once
(defvar *seglen* 12)
; how far to advance to the next chunk of symbols;
; should be minimum 1 and not more than *seglen* in
; order to allow overlapping evaluation
(defvar *stepsize* 5)
; the signal that input/output has ended; not
; to be supplied by the user - handled automatically
(defvar *terminator* 'TRM)
; how far a plan can be composed
(defvar *max-plan-range* 20) ; was 10
; how many planning steps would be allowed
(defvar *max-plan-steps* 25) ; normally greater or equal to range ; was 8
; how many symbols shall the short-term memory hold
(defvar *max-history-length* 33)
; how many elements shall knowledge contain -
; remembered are only super-structures, i.e. lists,
; not just singular symbols as these have no structure,
; i.e. do not support structural recognition or usage per se
; (but only as part of a super-structure)
(defvar *max-knowledge-length* 2000)
; generate an initial empty knowledge
(defvar *knowledge* (gen-sym *max-knowledge-length* '()))
; generate an initial empty history
(defvar *history* (gen-sym *max-history-length* '()))
; this is "a hack" - avoid the system telling "nothing"
; if it could give some other answer - avoids a way too
; taciturn system that prefers to give no replies at all
(defvar *allow-terminator* '())
; like Lisp's nthcdr
(defun nth-cdr (n lis)
(loop
(cond ((null lis) (return '()))
((zerop n) (return lis)))
(pop lis)
(decf n)))
; take-first takes the first n elements of a list,
; in a way a complementary effect to nthcdr, only
; with the beginning of a list and not its end
(defun proto-take-first (n lis res)
(loop
(cond ((or (zerop n) (null lis)) (return res)))
(setq res (append res (list (car lis)))) ; slow, but lower memory
(pop lis)
(decf n)))
(defun take-first (n lis) (proto-take-first n lis '()))
; (take-first 3 '(A B C D)) --> (A B C)
; take the last n elements of a list
(defun take-last (n lis)
(loop
(cond ((null (nth-cdr n lis)) (return lis)))
(pop lis)))
; this is like Lisp's butlast
(defun proto-but-last (lis res)
(loop
(cond ((null (cdr lis)) (return res)))
; the below ridiculous mechanism was done
; in the hope to decrease memory usage,
; though clearly this is painfully slow
(setq res (append res (list (car lis)))) ; slow... low
(pop lis)))
(defun but-last (lis) (proto-but-last lis '()))
; an equal-operator that matches lists - nice to have;
; the complex structures to be recognised by the system
; will be lists and these cannot be matched with mere eq
(defun ek (a b)
(cond ((eq a b) t)
((and (listp a) (listp b))
(cond ((or (null a) (null b)) '())
; that was because the above eq would have caught
; a mutual nil
((not (ek (car a) (car b))) '()) ; deep recursion
(t (ek (cdr a) (cdr b)))))
(t '())))
; (ek '((A B) (C D E)) '((A B) (C D E))) --> T
; (defun final (lis)
; (cond ((null lis) '())
; (t (car (reverse lis)))))
; this really works like "car", but gives the
; very last element of a list; this is useful for
; "forgetting", if combined with butlast:
; assuming the last element of a list is "least
; relevant" in some chosen model of priority,
; butlast will give you the "valid" part of
; some knowledge list, whereas "final" will
; give you the element to be "forgotten" - and whose
; symbol or "space", then, can be somehow re-used
(defun final (lis)
(loop
(cond ((null lis) (return '()))
((null (cdr lis)) (return (car lis))))
(pop lis)))
; ((final '(A B C)) --> C
; this is like member, but with ek, not just eq,
; and is useful for seeking membership of
; complex structures in a list - e.g. main knowledge
(defun memb (el lis)
(loop
(cond ((null lis) (return '()))
((ek el (car lis)) (return lis)))
(pop lis)))
; ; (defun forget-element-from-list (el lis)
; ; (cond ((null lis) '()) ; should never happen
; ; ((null (cdr lis)) '()) ; FORGET last element
; ; ((ek (car lis) el) (cdr lis)) ; FORGOT the element - for bubbling purposes!
; ; (t (cons (car lis) (forget-element-from-list el (cdr lis))))))
;
; (defun proto-forget-element-from-list (el lis frnt)
; (loop
; (cond ((null lis) (return '())) ; should never happen
; ((null (cdr lis)) (return frnt)) ; FORGET last element
; ((ek (car lis) el) (return (append frnt (cdr lis))))) ; FORGOT the element - for bubbling purposes!
; (setq frnt (append frnt (list (car lis)))) ; slow... low mem
; (pop lis)))
;
; (defun forget-element-from-list (el lis)
; (proto-forget-element-from-list el lis '()))
;
; (defun bubble (el lis) ; no bubbling for elementary atoms and for nils - BUBBLING IS THE ESSENCE OF LEARNING, DO NOT LEARN SUCH TRASH!
; (cond ((not (listp el)) lis)
; ((null el) lis)
; (t (cons el (forget-element-from-list el lis)))))
; ; (defun proto-match-knowledge-pair (history-pair reverse-history-pair knowledge)
; ; (cond ((null knowledge) '()) ; no match for the pair found
; ; ((ek history-pair (car knowledge)) history-pair) ; and THEN it's bubbled later
; ; ((ek reverse-history-pair (car knowledge)) '()) ; Antithesis found: "certainly NOT that pair!"
; ; (t (proto-match-knowledge-pair history-pair reverse-history-pair (cdr knowledge)))))
;
; ; This function checks whether a pair - or its antithesis - are found in knowledge
; (defun proto-match-knowledge-pair (history-pair reverse-history-pair knowledge)
; (loop
; (cond ((null knowledge) (return '())) ; no match for the pair found
; ((ek history-pair (car knowledge)) (return history-pair)) ; and THEN it's bubbled later
; ((ek reverse-history-pair (car knowledge)) (return '()))) ; Antithesis found: "certainly NOT that pair!"
; (pop knowledge)))
;
; ; (defun proto2-match-knowledge-pair (reversed-history knowledge) ; the first matching a more recent piece of knowledge
; ; (cond ((null reversed-history) '()) ; should never happen
; ; ((null (cdr reversed-history)) '()) ; should not happen, either - should be CAUGHT BEFOREHAND
; ; (t (let ((p-m (proto-match-knowledge-pair
; ; (list (cadr reversed-history) (car reversed-history))
; ; (list (car reversed-history) (cadr reversed-history))
; ; knowledge)))
; ; (cond ((null p-m) (proto2-match-knowledge-pair (cdr reversed-history) knowledge))
; ; (t p-m))))))
;
; ; try to match the most recent known pair of the input to the knowledge
; (defun proto2-match-knowledge-pair (reversed-history knowledge) ; the first matching a more recent piece of knowledge
; (loop
; (cond ((null reversed-history) (return '())) ; should never happen
; ((null (cdr reversed-history)) (return '())) ; should not happen, either - should be CAUGHT BEFOREHAND
; (t (let ((p-m (proto-match-knowledge-pair
; (list (cadr reversed-history) (car reversed-history))
; (list (car reversed-history) (cadr reversed-history))
; knowledge)))
; (cond ((not (null p-m)) (return p-m))))))
; (pop reversed-history)))
;
; ; (defun proto-guess-pair (history but-last-his rev-cdr-his knowledge)
; ; (cond ((or (null history) (null knowledge)) '())
; ; ((null (cdr history)) '())
; ; ((null (car knowledge))
; ; (proto-guess-pair history but-last-his rev-cdr-his (cdr knowledge)))
; ; ((memb (caar knowledge) but-last-his)
; ; (take-first 2 (memb (caar knowledge) history)))
; ; ((memb (cadar knowledge) rev-cdr-his)
; ; (reverse (take-first 2 (memb (cadar knowledge) (reverse history)))))
; ; (t
; ; (proto-guess-pair history but-last-his rev-cdr-his (cdr knowledge)))))
;
; if you don't want to bother with lists filled
; aftificially with nil-symbols, this deletes these symbols
(defun eat-nils (lis)
(loop
(cond ((null lis) (return '()))
((not (null (car lis))) (return lis)))
(pop lis)))
; (defun pproto-guess-pair (history but-last-his rev-cdr-his knowledge)
; (loop
; (cond ((or (null history) (null knowledge)) (return '()))
; ((null (cdr history)) (return '()))
; ((memb (caar knowledge) but-last-his)
; (return (take-first 2 (memb (caar knowledge) history))))
; ((memb (cadar knowledge) rev-cdr-his)
; (return (reverse (take-first 2 (memb (cadar knowledge) (reverse history)))))))
; (pop knowledge)))
;
; (defun proto-guess-pair (history but-last-his rev-cdr-his knowledge)
; (pproto-guess-pair history but-last-his rev-cdr-his (eat-nils knowledge)))
;
; (defun guess-pair (history knowledge)
; (cond ((null history) '())
; ((null (cdr history)) '())
; (t (let ((guess (proto-guess-pair history
; (but-last history)
; (reverse (cdr history))
; knowledge)))
; (cond ((null guess)
; (let ((rev-his (reverse history)))
; (list (cadr rev-his) (car rev-his))))
; (t guess))))))
; (guess-pair '(A B C D) '((R S) (T U) (B X) (V W))) --> (B C)
; (guess-pair '(A B C D) '((R S) (T U) (Y C) (V W))) --> (B C)
; CHECK NOW IS THE HISTORY EITHER EMPTY OR DOES IT PERHAPS HAVE ONLY ONE ELEMENT;
; and EAT UP the history in so far as it begins with NULLs!
; (defun pr-match-knowledge-pair (history knowledge)
; (cond ((null history) '())
; ((null (cdr history)) '())
; (t (let ((p-match (proto2-match-knowledge-pair (reverse history) knowledge)))
; (cond ((null p-match) (guess-pair history knowledge)) ; BUBBLE THIS LATER: LEARN IT, POTENTIALLY!
; (t p-match)))))) ; BUBBLE THIS LATER
; (defun match-knowledge-pair (history knowledge)
; (pr-match-knowledge-pair (eat-nils history) knowledge))
; THE HISTORY IS TO BE SEGMENTED INTO SENSIBLE SEGMENTS, AND ONLY _THESE_ ARE TO BE LEARNED: THAT IS A SORT OF "CREEPING"!
; SEGMENTS SHOULD BE *N* ATOMS APART, NOT ONLY 1! ACCELERATE EVALUATION!
; (defun h-hierarchise-pair (history-segment knowledge)
; (cond ((null history-segment) '()) ; should never happen unless history-segment is reduced by eat-nils
; ((null (cdr history-segment)) history-segment) ; here, not NIL: allow the ONE listed atom
; ; to continue being used for planning, if needed
; (t (match-knowledge-pair history-segment knowledge))))
; (defun hierarchise-pair (history-segment knowledge)
; (h-hierarchise-pair (eat-nils history-segment) knowledge))
; assume you want to "recognise a structure", e.g. A and B
; as (A B), then this will turn a list of (X Y Z A B C)
; into (X Y Z (A B) C), i.e. therein (A B) is ONE unit
; and the "structuring" of the given list has advanced:
(defun hier-pair (h-pair history-segment)
(cond ((null history-segment) '())
((null (cdr history-segment)) history-segment)
((ek h-pair (list (car history-segment) (cadr history-segment)))
(cons h-pair (hier-pair h-pair (cddr history-segment))))
(t
(cons (car history-segment) (hier-pair h-pair (cdr history-segment))))))
; ALTERNATIVE I:
; (defun hierarchise-all-segment (history-segment knowledge) ; result: LAST ATOM + BUBBLED KNOWLEDGE
; (cond ((null history-segment) (list '() knowledge)) ; should not happen
; ((null (car history-segment)) (hierarchise-all-segment (cdr history-segment) knowledge))
; ((null (cdr history-segment)) (list (car history-segment) (bubble (car history-segment) knowledge)))
; (t (let ((h-pair (hierarchise-pair history-segment knowledge)))
; (cond ((null h-pair) (list (final history-segment) (bubble (final history-segment) knowledge)))
; (t (hierarchise-all-segment (hier-pair h-pair history-segment) (bubble h-pair knowledge))))))))
; ALTERNATIVE II:
; ; knowledge is NOT YET BUBBLED above; this happens now:
; (defun h-hierarchise-all-segment (history-segment knowledge h-pair) ; result: LAST ATOM + BUBBLED KNOWLEDGE
; (loop
; (cond ((null history-segment) (return (list '() knowledge))) ; should not happen
; ((null (cdr history-segment)) (return (list (car history-segment) (bubble (car history-segment) knowledge)))))
; (setq h-pair (hierarchise-pair history-segment knowledge))
; (cond ((null h-pair) (return (list (final history-segment) (bubble (final history-segment) knowledge))))
; (t (progn
; (setq history-segment (hier-pair h-pair history-segment))
; (setq knowledge (bubble h-pair knowledge)))))
; ; (gc) (room) ; (gc) changes the results really a lot - it all becomes MUCH more "stable"
; )) ; so (room) above can easily be commented off.
;
; (defun hierarchise-all-segment (history-segment knowledge)
; (h-hierarchise-all-segment (eat-nils history-segment) knowledge '()))
; ALTERNATIVE III:
; This is THE largest function of this entire program.
; It is a manually inlined mess of a whole bunch of
; other functions, with hope to save some memory.
; In the end, it should fully "hierarchise" or
; structure the present - into one symbol - and
; update the knowledge accordingly, implanting into
; the knowledge the recognised or hypothetised
; structural elements (so they may serve as future
; models for recognition of structures) and updating
; their "priority" (placing them at the "top" or front
; of knowledge) as well as changing a segment of
; "history" (or input) in such a way that it becomes
; structured. E.g. the input or history segment (A B C A B)
; given to the knowledge ((R S) (T U) (B X) (V W) (W E) (E D)))
; should result in a list of the now structured input as
; well as in an updated knowledge (that has learned the
; newly hypothetised structurings):
; (((A (B C)) (A B)) ; input, and this is knowledge:
; (((A (B C)) (A B)) (A (B C)) (A B) (B C) (R S) (T U)))
(defun h-hierarchise-all-segment (history-segment knowledge h-pair frnt rs nh rh nk)
; --> auxiliary variables
(loop
(cond ((null history-segment) (return (list '() knowledge))) ; should not happen - history should not be empty
((null (cdr history-segment)) ; history has then only one element: FULL STRUCTURE is achieved
(return
(progn (setq frnt '()) ; auxiliary catcher for checked knowledge elements
(list
(car history-segment) ; the final "top structure" of the present segment
(cons ; and knowledge:
(car history-segment) ; ... which is given the "most priority" at the front
; ... but at the same time this "top structure" is forgotten from the body,
; in order to avoid any "copies" of it within the knowledge which would
; only waste knowledge capacity; if the structure does not exist in the
; body, the knowledge is shortened by one element, so the attachment to
; the front does not increase its length and it remains constant
(loop
(cond ((null knowledge) (return '())) ; should never happen
((null (cdr knowledge)) (return frnt)) ; FORGET last knowledge element
((ek (car knowledge) (car history-segment))
(return (append frnt (cdr knowledge))))) ; remove the known top atom from the body
(setq frnt (append frnt (list (car knowledge)))) ; slow... low mem: recycle the checked knowledge elements
(pop knowledge))))))))
; (setq h-pair (hierarchise-pair history-segment knowledge)) ; now becomes:
; OK, if you did not "return" from the loop before, then it is safe to say, you did NOT
; gain yet "final" structuring or hierarchisation of the present - and you should
; rather go ahead and proceed doing such structuring:
(setq h-pair
(progn
; we do not wish to deal with a history-segment full of nils (though it works anyway):
(setq history-segment (eat-nils history-segment))
; ex h-hierarchise-pair (history-segment knowledge)
(cond ((null history-segment) '())
((null (cdr history-segment)) history-segment)
(t
; ex pr-match-knowledge-pair (history knowledge)
(cond ((null history-segment) '())
((null (cdr history-segment)) '()) ; ... maybe unnecessary - check for history of length at least 2,
; as two symbols are the required length for a structuring
(t (let ((p-match ; (proto2-match-knowledge-pair (reverse history-segment) knowledge)
(progn
; ex proto2-match-knowledge-pair (reversed-history knowledge)
(setq rs (reverse history-segment))
(loop
(cond ((null rs) (return '())) ; should never happen
((null (cdr rs)) (return '())) ; should not happen, either - should be CAUGHT BEFOREHAND
(t (let ((p-m
; ex proto-match-knowledge-pair (history-pair reverse-history-pair knowledge)
(progn
(setq nh (list (cadr rs) (car rs)))
(setq rh (list (car rs) (cadr rs)))
(setq nk '())
(loop
(cond ((null nk) (return '()))
((ek nh (car nk)) (progn
(setq knowledge (append (reverse nk) knowledge))
(setq nk '())
(return nh)))
((ek rh (car nk)) (progn
(setq knowledge (append (reverse nk) knowledge))
(setq nk '())
(return '()))))
(push (pop knowledge) nk)))
; ; faster, but more memory-hungry alternatively to above progn:
; (progn
; (setq nh (list (cadr rs) (car rs)))
; (setq rh (list (car rs) (cadr rs)))
; (setq nk knowledge) ; THIS COPY SEEMS UNAVOIDABLE
; (loop
; (cond ((null nk) (return '()))
; ((ek nh (car nk)) (progn (setq nk '()) (return nh)))
; ((ek rh (car nk)) (progn (setq nk '()) (return '()))))
; (pop nk)))
)) ; parentheses of p-m
(cond ((not (null p-m)) (return p-m))))))
(pop rs)))))
(cond ((null p-match)
; ex guess-pair (history knowledge)
(cond ((null history-segment) '())
((null (cdr history-segment)) '())
(t (let ((guess
(progn
(setq nk '())
; ex pproto-guess-pair (history but-last-his rev-cdr-his knowledge)
(let ((but-last-his (but-last history-segment))
(rev-cdr-his (reverse (cdr history-segment))))
(loop
(cond
((or (null history-segment) (null knowledge)) (return '()))
((null (cdr history-segment)) (return '()))
((memb (caar knowledge) but-last-his)
(return (take-first 2 (memb (caar knowledge) history-segment))))
((memb (cadar knowledge) rev-cdr-his)
(return (reverse (take-first 2 (memb (cadar knowledge) (reverse history-segment)))))))
(push (pop knowledge) nk))))))
(progn
(setq knowledge (append (reverse nk) knowledge))
(setq nk '())
(cond ((null guess)
(let ((rev-his (reverse history-segment)))
(list (cadr rev-his) (car rev-his))))
(t guess)))))))
(t p-match)))))))))
(cond ((null h-pair)
(return
(progn (setq frnt '())
(list
(final history-segment)
(cons
(final history-segment)
; ex proto-forget-element-from-list
(loop
(cond ((null knowledge) (return '())) ; should never happen
((null (cdr knowledge)) (return frnt)) ; FORGET last element
((ek (car knowledge) (final history-segment))
(return (append frnt (cdr knowledge))))) ; FORGOT the element - for bubbling purposes!
(setq frnt (append frnt (list (car knowledge)))) ; slow... low mem
(pop knowledge)))))))
(t (progn
(setq history-segment (hier-pair h-pair history-segment))
(setq frnt '())
(setq knowledge
(cons h-pair
(loop
(cond ((null knowledge) (return frnt)) ; should never happen
((null (cdr knowledge)) (return frnt)) ; FORGET last element
((ek (car knowledge) h-pair)
(return (append frnt (cdr knowledge))))) ; FORGOT the element - for bubbling purposes!
(setq frnt (append frnt (list (car knowledge)))) ; slow... low mem
(pop knowledge)))))))
; (gc) (room) ; (gc) changes the results really a lot - it all becomes MUCH more "stable"
)) ; so (room) above can easily be commented off.
(defun hierarchise-all-segment (history-segment knowledge)
(h-hierarchise-all-segment (eat-nils history-segment) knowledge '() '() '() '() '() '()))
**; (hierarchise-all-segment '(A B C A B) '((R S) (T U) (B X) (V W) (W E) (E D)))**
**; -->**
**; (((A (B C)) (A B)) (((A (B C)) (A B)) (A (B C)) (A B) (B C) (R S) (T U)))**
^^^^^^^^ IT IS THIS LAST FUNCTION CALL THAT DOES NOT WORK OUT AS IN SBCL
It delivers nil instead of the structured lists.