How to sort people in JESS? - jess

This is the code of my program to sort people gender wise and age wise. I am getting the output but not as expected.
(deffacts initial-phase
(phase choose-gender)
(phase choose-age)
(phase choose-name))
(deffacts person (gender) (age) (name))
(deffunction ask-start-again ()
(printout t "Enter another person? (y/n) ")
(if (eq (read) y) then
(assert (phase choose-gender)
(phase choose-age)
(phase choose-name))))
(deffunction comparePerson(?pa ?pb $?comp)
(if (< ((nth$ 1 $?comp) ?pa ?pb) 0) then (return -1))
(if (> ((nth$ 1 $?comp) ?pa ?pb) 0) then (return 1))
(if (= (length$ $?comp) 1) then (return 0))
(return (comparePerson ?pa ?pb (rest$ $?comp))))
;RULES
(defrule gender-select
(phase choose-gender)
=>
(printout t "what is your gender (Male: m "
"Female: f)? ")
(assert (gender-select (read))))
(defrule good-gender-choice
?phase <- (phase choose-gender)
?choice <- (gender-select ?gender&:(or (eq ?gender m) (eq ?gender f)))
=>
(retract ?phase ?choice)
(assert (gender ?gender))
(assert (phase select-age)))
(defrule bad-gender-choice
?phase <- (phase choose-gender)
?choice <- (gender-select ?player&~m&~f)
=>
(retract ?phase ?choice)
(assert (phase choose-gender))
(printout t "Choose m or f." crlf))
(defrule age-select
(phase select-age)
=>
(printout t "What is your age? ")
(assert (age-select (read))))
(defrule good-age-choice
?phase <- (phase select-age)
?choice <- (age-select ?age&:(integerp ?age)
&:(> ?age 0))
=>
(retract ?phase ?choice)
(assert (age ?age))
(assert (phase select-name)))
(defrule bad-age-choice
?phase <- (phase select-age)
?choice <- (age-select ?age&:(or (not (integerp ?age))
(<= ?age 0)))
=>
(retract ?phase ?choice)
(assert (phase select-age))
(printout t "Choose an integer greater than zero."
crlf))
(defrule name-select
(phase select-name)
=>
(printout t "What is your name? ")
(assert (name-select (read))))
(defrule good-name-choice
?phase <- (phase select-name)
?choice <- (name-select ?name&:(or (not (integerp ?name))))
=>
(retract ?phase ?choice)
(assert (name ?name)))
(defrule bad-name-choice
?phase <- (phase select-name)
?choice <- (name-select ?name&:(integerp ?name))
=>
(retract ?phase ?choice)
(assert (phase select-name))
(printout t "Please enter a name."
crlf))
(defrule person-old-female
?gender <- (gender f)
?age <- (age ?b&:(> ?b 35))
=>
(printout t "Person is female & older. This Person must go first!" crlf)
(retract ?gender)
(retract ?age)
(ask-start-again))
(defrule person-young-female
?gender <- (gender f)
?age <- (age ?age&:(<= ?age 35))
=>
(printout t "Person is female & younger. This Person must go after older males!" crlf)
(retract ?gender)
(retract ?age)
(ask-start-again))
(defrule person-old-male
?gender <- (gender m)
?age <- (age ?a&:(> ?a 35))
=>
(printout t "Person is male & older. This Person must go after older females!" crlf)
(retract ?gender)
(retract ?age)
(ask-start-again))
(defrule person-young-male
?gender <- (gender m)
?age <- (age ?age&:(<= ?age 35))
=>
(printout t "Person is male & younger. This Person must go after younger females!" crlf)
(retract ?gender)
(retract ?age)
(ask-start-again))
(defrule print-solution
=>
(printout t "Name Age Gender" crlf)
(printout t "--------------------------------------" crlf))
(defrule print-all-persons
(declare (salience -1000))
(person (name ?name) (age ?age) (gender ?gender))
=>
(printout t ?name ?age ?gender crlf))
(defrule findFirst
?p1 <- (person)
(not (and ?p2 <- (person)
(test (< (comparePerson ?p2 ?p1) 0))))
=>
(retract ?p1))
(defrule findFirst
?phase <- (phase sort-persons)
?p1 <- (person)
(not (and ?p2 <- (person)
(test (< (comparePerson ?p2 ?p1 ?*compAge* ?*compGender*) 0))))
=>
(printout t (fact-slot-value ?p1 name) " selected" crlf)
(retract ?p1))
(defglobal ?*compAge* =
(lambda (?pa ?pb)
(- (fact-slot-value ?pb age) (fact-slot-value ?pa age) )))
(defglobal ?*compGender* =
(lambda (?pa ?pb)
(- (asc (fact-slot-value ?pa gender))
(asc (fact-slot-value ?pb gender)))))
(reset)
(run)
And this is the output It does not display the output as a list of persons. I don't know what i am missing.
Is it possible to get the output like
"male 30 a
male 40 b
female 25 c
female 50 d"
What changes do I have to make to get the output as a list and sort it? thank you.

Assert one phase at a time:
(deffacts initial-phase (phase choose-gender))
and make sure to assert the sort phase after all input:
(deffunction ask-start-again ()
(printout t "Enter another person? (y/n) ")
(if (eq (read) y) then
(assert (phase choose-gender))
else
(assert (phase sort-persons))))
Use correct syntax for defining a template:
(deftemplate person (slot gender) (slot age) (slot name))
Asserting a person ("deffacts person") doesn't make sense.
Remove the first defrule findFirst - there is another one with the same name.
You need a rule to define a person:
(defrule define-person
?gf
(retract ?gf ?af ?nf)
(assert (person (age ?age)(name ?name)(gender ?gender)))
(ask-start-again))
Rules person-old/yound-male/female aren't useful - they just retract the data collected earlier. Also, print-all-persons doesn't help with printing the sorted facts; add a similar printout function call in rule findFirst (second version).

Related

Rules for arranging people age wise and gender wise

This is my whole program for sorting people gender wise and age wise. The older should come before younger and the female should come male.
(deftemplate person (slot gender)
(slot age (type INTEGER))
(slot name))
(deffacts initial-phase
(phase choose-gender)
(phase choose-age)
(phase choose-name))
; ********
; DEFFUNCTIONS
; ********
(deffunction ask-start-again ()
(printout t "Enter another person? (y/n) ")
(if (eq (read) y) then
(assert (phase choose-gender)
(phase choose-age)
(phase choose-name))))
;RULES
(defrule gender-select
(phase choose-gender)
=>
(printout t "what is your gender (Male: m "
"Female: f)? ")
(assert (gender-select (read))))
(defrule good-gender-choice
?phase <- (phase choose-gender)
?choice <- (gender-select ?gender&:(or (eq ?gender m) (eq ?gender f)))
=>
(retract ?phase ?choice)
(assert (gender ?gender))
(assert (phase select-age)))
(defrule bad-gender-choice
?phase <- (phase choose-gender)
?choice <- (gender-select ?player&~m&~f)
=>
(retract ?phase ?choice)
(assert (phase choose-gender))
(printout t "Choose m or f." crlf))
(defrule age-select
(phase select-age)
=>
(printout t "What is your age? ")
(assert (age-select (read))))
(defrule good-age-choice
?phase <- (phase select-age)
?choice <- (age-select ?age&:(integerp ?age)
&:(> ?age 0))
=>
(retract ?phase ?choice)
(assert (age ?age))
(assert (phase select-name)))
(defrule bad-age-choice
?phase <- (phase select-age)
?choice <- (age-select ?age&:(or (not (integerp ?age))
(<= ?age 0)))
=>
(retract ?phase ?choice)
(assert (phase select-age))
(printout t "Choose an integer greater than zero."
crlf))
(defrule name-select
(phase select-name)
=>
(printout t "What is your name? ")
(assert (name-select (read))))
(defrule good-name-choice
?phase <- (phase select-name)
?choice <- (name-select ?name&:(or (not (integerp ?name))))
=>
(retract ?phase ?choice)
(assert (name ?name)))
(defrule bad-name-choice
?phase <- (phase select-name)
?choice <- (name-select ?name&:(integerp ?name))
=>
(retract ?phase ?choice)
(assert (phase select-name))
(printout t "Please enter a name."
crlf))
(defrule old-female-first
?gender <- (gender f)
?age <- (age ?b&:(> ?b 35))
=>
(printout t "Person is female & older. This Person must go first!" crlf)
(retract ?gender)
(retract ?age)
(ask-start-again))
(defrule young-female-third
?gender <- (gender f)
?age <- (age ?age&:(<= ?age 35))
=>
(printout t "Person is female & younger. This Person must go after older males!" crlf)
(retract ?gender)
(retract ?age)
(ask-start-again))
(defrule old-male-second
?gender <- (gender m)
?age <- (age ?a&:(> ?a 35))
=>
(printout t "Person is male & older. This Person must go after older females!" crlf)
(retract ?gender)
(retract ?age)
(ask-start-again))
(defrule young-male-last
?gender <- (gender m)
?age <- (age ?age&:(<= ?age 35))
=>
(printout t "Person is male & younger. This Person must go after younger females!" crlf)
(retract ?gender)
(retract ?age)
(ask-start-again))
(defrule print-all-persons
(declare (salience -1000))
(person (name ?name) (age ?age) (gender ?gender))
=>
(printout t ?name ?age ?gender crlf))
(reset)
(run)
The code is not giving any error but also not getting expected output.
Here is the code.
(deftemplate Person (slot gender) (slot name) (slot age(type INTEGER)))
(deffunction validateName (?personname)
(bind ?stringLen (str-length ?personname))
(bind ?index 1)
(while (>= ?stringLen ?index)
(bind ?currentChar (sub-string ?index ?index ?personname))
(bind ?ASCIIValue (asc ?currentChar))
(if (and (>= ?ASCIIValue 0) (<= ?ASCIIValue 64)) then (return 0))
(if (and (>= ?ASCIIValue 91) (<= ?ASCIIValue 96)) then (return 0))
(if (>= ?ASCIIValue 123) then (return 0))
(bind ?index (+ ?index 1))
)
(return 1)
)
(deffunction getGender()
(printout t "Enter Gender (M|F) : ")
(bind ?localGender (read))
(if (or (eq (upcase ?localGender) M) (eq (upcase ?localGender) F))
then
(return ?localGender)
)
(printout t "Invalid Gender... Try Again..." crlf crlf)
(return (getGender()))
)
(deffunction getName()
(printout t "Enter Name : ")
(bind ?localName (readline))
(if (eq (validateName ?localName) 1) then (return ?localName))
(printout t "Invalid Name... Try Again..." crlf crlf)
(return (getName()))
)
(deffunction getAge()
(printout t "Enter Age : ")
(bind ?localAge (read))
(if (integerp ?localAge) then (if (> ?localAge 0) then (return ?localAge)))
(printout t "Invalid Age... Try Again..." crlf crlf)
(return (getAge()))
)
(deffunction showAllPesron()
(printout t crlf"-------------------------------" crlf)
(printout t " Person List " crlf)
(printout t "-------------------------------" crlf)
(printout t "Gender | Age | Name" crlf)
(printout t "-------------------------------" crlf)
)
(deffunction getPersonDetail()
(printout t crlf)
(bind ?gender (getGender()))
(bind ?name (getName()))
(bind ?age (getAge()))
(if (eq (upcase ?gender) M) then (assert (Person (gender M) (name ?name) (age ?age))))
(if (eq (upcase ?gender) F) then (assert (Person (gender F) (name ?name) (age ?age))))
(printout t crlf)
)
(defrule show-person-order
?P <- (Person (gender ?gender1) (name ?name1) (age ?age1))
(not (Person (age ?age2&:(> ?age2 ?age1))))
=>
(printout t ?gender1" "?age1" "?name1 crlf)
(retract ?P)
)
(deffunction main()
(printout t "Add another person? (Y|N) : ")
(bind ?addAnother (read))
(if (eq (upcase ?addAnother) Y) then (getPersonDetail()) (main()))
)
(getPersonDetail())
(main())
(showAllPesron())
(run)
(reset)
Here is an answer to your question which will, perhaps, not be easy to understand. However, I'll try and add lots of comments.
The fundamental idea of this "sort" is to identify person facts in the sort order: older before younger, female before male. After finding the winner fact it is retracted, so that the rule can fire again with the second best, and so on, until all person facts have been retracted.
Here is the rule in pseudo-code:
(defrule findFirst
?p1 <- (person)
not ?p2 <- (person ranked before ?p1)
=>
(retract ?p1))
Since the ranking involves more than one slot it is best written as a function which can be called with ?p1 and ?p2 as arguments. The compare
function can be written to return -1, 0 or +1, just like Java's compare methods.
(defrule findFirst
?p1 <- (person)
(not (and ?p2 <- (person)
(test (< (comparePerson ?p2 ?p1) 0))))
=>
(retract ?p1))
It would be nice if we could write the compare function in a flexible way so that another sort order wouldn't require a complete new function. This can be done by using lambdas - anonymous deffunctions - each of which compares just one slot. Here are the ones for age and gender, assigned to globals so that they are accessible from a rule's LHS:
(defglobal ?*compAge* =
(lambda (?pa ?pb)
(- (fact-slot-value ?pb age) (fact-slot-value ?pa age) )))
(defglobal ?*compGender* =
(lambda (?pa ?pb)
(- (asc (fact-slot-value ?pa gender))
(asc (fact-slot-value ?pb gender)))))
(Note the reversal of ?pa and ?pb to get descending age order.) We can now write the comparePerson function, which receives two person facts (?pa, ?pb) and a list of lambdas ($?comp).
(deffunction comparePerson(?pa ?pb $?comp)
;; if a comparison with the first function yields a decision, return it
(if (< ((nth$ 1 $?comp) ?pa ?pb) 0) then (return -1))
(if (> ((nth$ 1 $?comp) ?pa ?pb) 0) then (return 1))
;; if this is the last function we have two equal persons: return 0
(if (= (length$ $?comp) 1) then (return 0))
;; otherwise call the compare function with the remaining functions
(return (comparePerson ?pa ?pb (rest$ $?comp))))
And now the rule, triggered with another value for the phase fact:
(defrule findFirst
?phase <- (phase sort-persons)
?p1 <- (person)
(not (and ?p2 <- (person)
(test (< (comparePerson ?p2 ?p1 ?*compAge* ?*compGender*) 0))))
=>
(printout t (fact-slot-value ?p1 name) " selected" crlf)
(retract ?p1))
Note: person facts are best assembled as soon as a correct name has been entered. There's no need to create and insert the name fact.

What this functions in Scheme language do?

I'm a newbie and I didn't understand very well the language. Could anyone please explain to me what this functions do?
First function:
(define (x l)
(cond
((null? l) 0)
((list? (car l))
(+ (x (car l)) (x (cdr l))))
(else (+ 1 (x (cdr l))))
))
Second function:
(define (x l)
(cond
((null? l) 0)
((list? (car l))
(+ (x (car l)) (x (cdr l))))
(else (+ (car l) (x (cdr l)))
))
I do understand the begining but the conditions I didn't understand. Any help?
I will call your second function y.
Writing in pseudocode,
x [] -> 0
x [a . b] -> x a + x b , if list a
x [a . b] -> 1 + x b , else, i.e. if not (list a)
y [] -> 0
y [a . b] -> y a + y b , if list a
y [a . b] -> a + y b , else, i.e. if not (list a)
So for example,
x [2,3] = x [2 . [3]]
= 1 + x [3]
= 1 + x [3 . []]
= 1 + (1 + x [])
= 1 + (1 + 0 )
and
y [2,3] = y [2 . [3]]
= 2 + y [3]
= 2 + y [3 . []]
= 2 + ( 3 + y [])
= 2 + ( 3 + 0 )
See? The first counts something in the argument list, the second sums them up.
Of course both functions could be called with some non-list, but then both would just cause an error trying to get (car l) in the second clause, (list? (car l)).
You might have noticed that the two are almost identical. They both accumulates (fold) over a tree. Both of them will evaluate to 0 on the empty tree and both of them will sum the result of the same procedure on the car and cdr when the car is a list?. The two differ when the car is not a list and in the first it adds 1 for each element in the other it uses the element itself in the addition. It's possible to write the same a little more compact like this:
(define (sum l)
(cond
((null? l) 0) ; null-value
((not (pair? l)) l) ; term
(else (+ (sum (car l)) (sum (cdr l)))))) ; combine
Here is a generalisation:
(define (accumulate-tree tree term combiner null-value)
(let rec ((tree tree))
(cond ((null? tree) null-value)
((not (pair? tree)) (term tree))
(else (combiner (rec (car tree))
(rec (cdr tree)))))))
You can make both of your procedures in terms of accumulate-tree:
(define (count tree)
(accumulate-tree tree (lambda (x) 1) + 0))
(define (sum tree)
(accumulate-tree tree (lambda (x) x) + 0))
Of course you can make a lot more than this with accumulate-tree. It doesn't have to turn into an atomic value.
(define (double tree)
(accumulate-tree tree (lambda (x) (* 2 x)) cons '()))
(double '(1 2 ((3 4) 2 3) 4 5)) ; ==> (2 4 ((6 8) 4 6) 8 10)

Print Coordinates on a Board

How can I print in my board an object (character # object I) in proper coordinates?
(deftemplate cenario
(slot min-line)
(slot max-line)
(slot min-column)
(slot max-column))
(deftemplate line
(slot index))
(deftemplate column
(slot index))
(deftemplate coordinate
(slot line)
(slot column))
(deftemplate object
(multislot coordinate))
(deffacts cenario
(cenario
(min-line 1)
(max-line 24)
(min-column 1)
(max-column 12)))
(deffacts line
(line (index 1))
(line (index 2))
(line (index 3))
(line (index 4))
(line (index 5))
(line (index 6))
(line (index 7))
(line (index 8))
(line (index 9))
(line (index 10))
(line (index 11))
(line (index 12))
(line (index 13))
(line (index 14))
(line (index 15))
(line (index 16))
(line (index 17))
(line (index 18))
(line (index 19))
(line (index 20))
(line (index 21))
(line (index 22))
(line (index 23))
(line (index 24)))
(deffacts column
(column (index 1))
(column (index 2))
(column (index 3))
(column (index 4))
(column (index 5))
(column (index 6))
(column (index 7))
(column (index 8))
(column (index 9))
(column (index 10))
(column (index 11))
(column (index 12)))
(deffacts I
(object (coordinate 5 24) (coordinate 6 24) (coordinate 7 24) (coordinate 8 24))))
(defrule startcolumn
(not(columnCurrent))
(cenario (min-column ?x))
=>
(assert(columnCurrent ?x)))
(defrule startline
(not(lineCurrent))
(cenario (max-line ?x))
=>
(assert(lineCurrent ?x)))
(defrule print-board
(cenario (max-column ?maxcol))
?f <- (line (index ?i))
?g <- (columnCurrent ?ca&:(<= ?ca ?maxcol))
(not (object (coordinate ?i ?ca)))
(lineCurrent ?i)
=>
(retract ?g)
(assert (columnCurrent (+ ?ca 1)))
(printout t "?"))
(defrule print-object
(lineCurrent ?i)
(columnCurrent ?ca)
(object (coordinate ?i ?ca ))
=>
(printout t ?i " " ?ca ))
(defrule change-line
(cenario (max-column ?maxcol))
?f <- (line (index ?i))
?g <- (columnCurrent 13)
(lineCurrent ?i)
=>
(retract ?f)
(assert (columnCurrent 1))
(assert (lineCurrent (- ?i 1)))
(printout t crlf))
I want this final result:
????####????
????????????
????????????
????????????
????????????
????????????
????????????
????????????
????????????
????????????
????????????
????????????
????????????
????????????
????????????
????????????
????????????
????????????
????????????
????????????
????????????
????????????
????????????
????????????
You can start with something like this.
(deftemplate point
(slot i(type INTEGER))
(slot j(type INTEGER))
)
(defglobal ?*ROWS* = 5)
(defglobal ?*COLS* = 5)
(deffacts initial
(currentRow 0)
(currentColumn 0)
(point(i 1)(j 1))
(point(i 1)(j 2))
(point(i 1)(j 3))
(point(i 2)(j 1))
(point(i 2)(j 3))
(point(i 3)(j 1))
(point(i 3)(j 2))
(point(i 3)(j 3))
)
(defrule print_1
"Prints 1 if there's a point to print"
?r<-(currentRow ?i)
?c<-(currentColumn ?j)
(point(i ?i)(j ?j))
=>
(printout t "1 ")
(retract ?c)
(assert (currentColumn (+ ?j 1)))
)
(defrule print_0
"Prints 0 if there's not any point to print"
?r<-(currentRow ?i)
?c<-(currentColumn ?j&:(<= ?j ?*COLS*))
(not(point(i ?i)(j ?j)))
=>
(printout t "0 ")
(retract ?c)
(assert (currentColumn (+ ?j 1)))
)
(defrule printNextRow
"If we have reached the limit"
?c<-(currentColumn ?j&:(> ?j ?*COLS*))
?r<-(currentRow ?i&:(< ?i ?*ROWS*))
=>
(printout t "" crlf)
(retract ?c)
(retract ?r)
(assert (currentColumn 0))
(assert (currentRow (+ ?i 1)))
)
(reset)
(run)
The idea is to emulate a for loop using only asserts/retracts.
Output:
Jess, the Rule Engine for the Java Platform
Copyright (C) 2008 Sandia Corporation
Jess Version 7.1p2 11/5/2008
0 0 0 0 0 0
0 1 1 1 0 0
0 1 0 1 0 0
0 1 1 1 0 0
0 0 0 0 0 0
0 0 0 0 0 0
Hope this helps
A multislot contains objects, but you cannot match objects within the list items. This will not work:
(object $? (coordinate ?i ?ca ) $?)
It should be possible to store a coordinate pair as a string (or folded integer):
(deffacts I
(object (coordinate "5.23" "6.23" "7.2" "8.2")))
And now rewrite the patterns according to
(object (coordinate $? ?x&=(str-cat ?i "." ?ca) $?)))
(Your loop over the lines doesn't work very well, but I don't want to waste my time with this absolutely non-declarative rule code. Sorry.)

Multiplication of Binary List in Scheme

I'm trying to implement an algorithm to multiply two bit-lists of 1s and 0s as a simulation to binary multiplication. It should return a like list, but I am having a hard time building on what I already have. Some help would be appreciated...
;;Function designed to accept two bit-list binary numbers (reverse order) and produce their product, a bitlist in reverse order.
;;Example: (multiply '(0 1 1 0 1) '(1 0 1)) should produce '(0 1 1 1 0 1 1)
(define (multiply x y)
(cond
;[(= null? y) 0]
[(zero? y) 0]
(#t (let ((z (multiply x (rest y )))) (cond
[(num_even? y) (cons 0 z)]
(#t (addWithCarry x (cons 0 z) 1)))))))
;This is to check if the current value of parameter x is the number 0
(define (zero? x)
(cond
((null? x) #t)
((=(first x) 1) #f)
(#t (zero? (rest x)))))
;This is to check if the current parameter x is 0 (even) or not.
(define (num_even? x)
(cond
[(null? x) #t]
[(=(first x) 0)#t]
[#t (num_even? (rest x))]))
;To add two binary numbers
(define(addWithCarry x y carry)
(cond
((and (null? x) (null? y)) (if (= carry 0) '( ) '(1)))
((null? x) (addWithCarry '(0) y carry))
((null? y) (addWithCarry x '(0) carry))
(#t (let ((bit1 (first x))
(bit2 (first y)))
(cond
((=(+ bit1 bit2 carry) 0) (cons 0 (addWithCarry (rest x)(rest y) 0)))
((=(+ bit1 bit2 carry) 1) (cons 1 (addWithCarry (rest x)(rest y) 0)))
((=(+ bit1 bit2 carry) 2) (cons 0 (addWithCarry (rest x)(rest y) 1)))
(#t (cons 1 (addWithCarry (rest x) (rest y) 1))))))))
Based on my previous answer for a base-10 multiplication, here's a solution that works for binary numbers (in the correct order):
(define base 2)
(define (car0 lst)
(if (empty? lst)
0
(car lst)))
(define (cdr0 lst)
(if (empty? lst)
empty
(cdr lst)))
(define (apa-add l1 l2) ; apa-add (see https://stackoverflow.com/a/19597007/1193075)
(let loop ((l1 (reverse l1))
(l2 (reverse l2))
(carry 0)
(res '()))
(if (and (null? l1) (null? l2) (= 0 carry))
res
(let* ((d1 (car0 l1))
(d2 (car0 l2))
(ad (+ d1 d2 carry))
(dn (modulo ad base)))
(loop (cdr0 l1)
(cdr0 l2)
(quotient (- ad dn) base)
(cons dn res))))))
(define (mult1 n lst) ; multiply a list by one digit
(let loop ((lst (reverse lst))
(carry 0)
(res '()))
(if (and (null? lst) (= 0 carry))
res
(let* ((c (car0 lst))
(m (+ (* n c) carry))
(m0 (modulo m base)))
(loop (cdr0 lst)
(quotient (- m m0) base)
(cons m0 res))))))
(define (apa-multi l1 l2) ; full multiplication
(let loop ((l2 (reverse l2))
(app '())
(res '()))
(if (null? l2)
res
(let* ((d2 (car l2))
(m (mult1 d2 l1))
(r (append m app)))
(loop (cdr l2)
(cons '0 app)
(apa-add r res))))))
so that
(apa-multi '(1 0 1 1 0) '(1 0 1))
=> '(1 1 0 1 1 1 0)

LISP function to remove nils

I want to write a function in LISP that will completely remove all NILS in a list. The list may be nested, meaning it can contain other lists inside. For example the list '((state L L L L) NIL (state L L R L) NIL) should be tranformed into '((STATE L L L L) (STATE L L R L)).
(defun remove-nil-recursively (x)
(if (listp x)
(mapcar #'remove-nil-recursively
(remove nil x))
x))
Works for your example:
[1]> (remove-nil-recursively '((state L L L L) NIL (state L L R L) NIL))
((STATE L L L L) (STATE L L R L))
And with nested lists:
[2]> (remove-nil-recursively '(NIL (state L L nil R L) NIL))
((STATE L L R L))
But watch out:
[3]> (remove-nil-recursively '(NIL (state L L (nil) R L) NIL))
((STATE L L NIL R L))
Paul Graham calls this function (recurring into sublists remove-if) "prune" in On Lisp, p. 49. It is one of the utility functions.
(defun prune (test tree)
(labels ((rec (tree acc)
(cond
((null tree) (nreverse acc))
((consp (car tree))
(rec (cdr tree)
(cons (rec (car tree) nil) acc)))
(t (rec (cdr tree)
(if (funcall test (car tree))
acc
(cons (car tree) acc)))))))
(rec tree nil)))
(prune #'evenp '(1 2 (3 (4 5) 6) 7 8 (9)))
(1 (3 (5)) 7 (9))
A generic function in the style of remove-if:
(defun remove-all (predic seq &optional res)
(if (null seq)
(reverse res)
(cond ((and (not (null (car seq))) (listp (car seq)))
(remove-all predic (cdr seq)
(cons (remove-all predic (car seq)) res)))
((funcall predic (car seq))
(remove-all predic (cdr seq) res))
(t (remove-all predic (cdr seq) (cons (car seq) res))))))
Examples:
> (remove-all #'null (list 1 2 'nil 3))
=> (1 2 3)
> (remove-all #'null (list 1 2 'nil '(4 5 nil 6) 3))
=> (1 2 (4 5 6) 3)
> (remove-all #'(lambda (x) (oddp x)) '(1 2 (3 4) 5 6 (7 8 (9 10))))
=> (2 (4) 6 (8 (10)))
(defun remove-if-nil (list) (remove-if-not 'identity list))
remove-if-not takes a predicate and a list, and removes all the items in the list that do not satisfy the predicate, that is, that return nil when evaluated in the predicate. identity, as you can guess, returns exactly the same thing it takes, so (remove-if-not 'identity list) removes every element in list that is nil.