In [2]:
(defmacro with-macros [binder &optional [delimitter ""] [redex False]]
`(init-system ~binder ~delimitter True ~redex))
(defmacro without-macros [binder &optional [delimitter ""] [redex False]]
`(init-system ~binder ~delimitter False ~redex))
(defmacro init-system [binder delimitter macros redex]
`(do
(try (do (import IPython)
(if (in 'display (.__dir__ IPython))
(import (IPython.display [HTML]))))
(except (e Exception)))
(eval-and-compile
(def redexes [])
; extend output rather than in place
(defn extend [a b] (.extend a b) a)
; reverse ouput rather than in place
(defn reverse [a] (.reverse a) a)
; is instance a function abstraction?
(defn function? [e] (instance? Function e))
; instead of straighforward native apply function, apply*
; will take care of the result that is possibly not a function but a list
; in that case result will be extended with the remaining arguments
(defn apply* [a b]
; by checking callable instead of function? we will extend the standard lambda
; function body to allow native hy/python function calls too
(while (and (callable a) b)
(def a (a (.pop b 0))))
(if b (extend a b) a))
; head normal form of the lambda application
(defn normalize [e]
(if-not (coll? e) e
(if (function? (first e))
(apply* (first e) (list (rest e)))
(if (function? e) e
; with HyList object instead of native list, we enable pretty printing
(do (def x (hy.HyList (map normalize e)))
(if (function? (first x)) (normalize x) x))))))
; prettier lambda function abstraction representation
(defn repr [e]
(if (and (coll? e) (not (function? e)))
; using HyList object comma separated list representations becomes more clear
(hy.HyList (map repr e)) e))
; lambda term / variable
(defclass Variable []
(defn --init-- [self x]
; crate the human readable name for the variable
(def self.x (name x)))
; show the human readable name
(defn --repr-- [self] self.x)
; if variable is the first element of the expression, then hy tries to use it
; as a function callee, thus we need to return both the callee and the
; possible arguments back intact
(defn --call-- [self &rest expr]
(extend [self] expr)))
; lambda function abstraction
(defclass Function [hy.HyList]
; pretty representation of the function. normally function in python / hy doesn't have
; any suitable printing format because of the arbitrary content of the function.
; in lambda calculus function body is structured in a very strict manner so we can
; show the exact content of the function body
(defn --repr-- [self]
(% "(%s %s%s%s)" (, '~binder (first self)
; one could normalize the second self, but max recursion error are probably impossible
; to handle in the self referencing forms
(if ~delimitter (% " %s " (, ~delimitter)) " ") (repr (second self)))))
; the function body to the normal head form (call by value)
(defn --call-- [self value &rest args]
(def expr (normalize ((last self) value)))
; if extra arguments are given then they are curryed forward
; insteadd of using apply we use a slightly modified functionality with apply*
(if args (apply* expr (list args)) expr))))
; main lambda macro
(defmacro ~binder [&rest expr]
(reduce (fn [body arg]
`((fn[] (def ~arg (Variable '~arg))
(Function ['~arg ~body (fn [~arg] ~body)])))) (reverse (list expr))))))
(without-macros L)
Out[2]:
In [3]:
;--------------------------------
; special forms
;--------------------------------
; named variables. multiple variables can be associated first, then the last expression is the body
; (LET a 1 b 2 (a b)) ->
; ((L a b (a b)) 1 2)
(defmacro LET [&rest args]
; all odd parameters except the last are argument names
(setv x (if args (cut (cut args 0 (len args) 2) 0 -1) ())
y (if args (cut args 1 (len args) 2) ())
z (if args (last args) ()))
(if args `((L ~@x ~z) ~@y)))
; same as LET but preceding variables are evaluated before using them on the body so that
; variables associated previously can be used on the later variables
; (LET* a 1 b a (a b)) ->
; (LET a 1 (LET b a (a b))) -> (1 1)
(defmacro LET* [&rest code]
(setv ; the last parameter in the expression is the body
expr (if code (last code) ())
; argument names are all odd except the last parameter
args (if code (cut (cut code 0 (len code) 2) 0 -1) ())
; values are all even parameters
vals (if code (cut code 1 (len code) 2) ()))
; create nested expressions but in reverse order
(for [[x y] (reverse (list (zip args vals)))]
(setv expr `((L ~x ~expr) ~y)))
;(if args expr `(~lambdachr ~separator ~@code)))
(if args expr code))
; the do structure for imperative style command sequences
; (DO (LET a 1) (LET b 2) (a b)) ->
; (LET a 1 (LET b 2 (a b))) -> (1 2)
(defmacro DO [&rest args]
; fold right with reduce reverse
(reduce (fn [x y] (extend y [x]))
(reverse (HyExpression args))))
; the constant macro takes the first argument as the name of the argument
; and the second argument as the function body. when the constant function is
; applied to any parameter, the static body will return be returned
; ((L x 1) 2) -> 1
(defmacro CONST [&rest args]
`(L ~(first args) ~@(rest args)))
Out[3]:
In [4]:
(defmacro NUM [n &rest args]
`(L x y ~(reduce (fn [x y] (hy.HyList ['x x])) (range n) 'y) ~@args))
; natural numbers
; ONE -> (L x y (x y))
(defmacro ℕ+ [number] `(NUM ~(abs number)))
(defsharp ℕ [number] `(ℕ+ ~number))
; church natural number to native the native one
(defn MUN [n]
(do (def x (n 1 0))
(if (numeric? x) x
(sum (flatten x)))))
;(defmacro defnat [&rest l]
; (for [[a b] (enumerate l)]
; `(def ~b (NUM ~a))))
;(defnat ZERO ONE TWO THREE FOUR FIVE)
; http://jwodder.freeshell.org/lambda.html
(def ; https://en.wikipedia.org/wiki/SKI_combinator_calculus
; S = apply x to y in the domain of z
S (L x y z [[x z] [y z]]) ; X (X (X (X X))) ≡ X K ≡ X′ (X′ X′) ≡ B (B (B W) C) (B B)
K (L a b a) ; X (X (X X)) ≡ X′ X′ X′
K′ (L a b b) ; X (X X) ≡ X′ X′
I (L x x) ; S K S ≡ S K K ≡ X X ≡ (X′ (X′ X′)) ((X′ X′) X′) X′
; https://en.wikipedia.org/wiki/B,_C,_K,_W_system
B (L x y z [x [y z]]) ; S (K S) K
C (L x y z [x z y]) ; S (S (K (S (K S) K)) S) (K K)
W (L x y [x y y]) ; S S (K (S K K))
W′ (L x y [x y x]) ; X (X (X (X (X X))))
; all above combinators could be presented by a single iota combinator:
X (L x [x S K]) ; (iota, (L x [x FALSE])
X′ (L x [x K S K]) ;
X′′ (L x [x K]) ;
; (X′ X′) = (I K K) = (L a TRUE)
; (X′ FALSE) = (I (K (S K))) = (L a FALSE)
; self referencial combinators
Y (L g [(L x [g [x x]]) (L x [g [x x]])]) ; S (K (S I I)) (S (S (K S) K) (K (S I I)))
Y′ [(L x y [x y x]) (L y x [y [x y x]])] ; S S K (S (K (S S (S (S S K)))) K)
Θ [(L x y [y [x x y]]) (L x y [y [x x y]])] ; Turing fixed-point combinator
ω (L x [x x]) ; S I I
Ω [ω ω]
Ω2 [(L x [x x x]) (L x [x x x])]
IDENT I ; (X X)
FALSE (L a b b) ; (L x I) (CONST x I) (S K) (X (X X))
TRUE K ; (X (X (X X)))
COND (L a b c [a b c])
NOT (L p [p FALSE TRUE]) ; (p FALSE TRUE)
AND (L a b [a b FALSE]) ; (a b FALSE)
OR (L a b [a TRUE b]) ; (a TRUE b)
XOR (L a b [a (NOT b) b]) ; (a (b FALSE TRUE) b)
NAND (L a b (NOT (AND a b))) ; (a b FALSE FALSE TRUE)
NOR (L a b (NOT (OR a b))) ; (a TRUE b FALSE TRUE)
XNOR (L a b (NOT (XOR a b))) ; (a (b FALSE TRUE) b FALSE TRUE)
IMP (L a b (OR (NOT a) b)) ; (a FALSE TRUE TRUE b)
NIMP (L a b (NOT (OR (NOT a) b))) ; (a FALSE TRUE TRUE b FALSE TRUE)
;MIMP (L a b (AND (NOT a) b)) ; (a FALSE TRUE b FALSE)
;NMIMP (L a b (NOT (AND (NOT a) b))) ; (a FALSE TRUE b FALSE FALSE TRUE)
EQV XNOR
NEQV NOR
ZERO FALSE
ZERO? (L s [s (L a FALSE) TRUE])
ONE (NUM 1) TWO (NUM 2)
THREE (NUM 3) FOUR (NUM 4)
FIVE (NUM 5) SIX (NUM 6)
SEVEN (NUM 7) EIGHT (NUM 8)
NINE (NUM 9) TEN (NUM 10)
SUM (L m n x y [m x [n x y]])
PRED (L n x y [n (L g h [h [g x]]) (L x y) (L x x)])
SUCC (L n x y [x [n x y]])
SUB (L m n [m PRED n])
PROD (L m n x y [m [n x] y])
EXP (L m n x y [n m x y])
LEQ? (L m n (ZERO? [n PRED m]))
EQ? (L m n (AND (LEQ? m n) (LEQ? n m)))
GE? (L m n (NOT (LEQ? m n)))
GEQ? (L m n (OR (GE? m n) (EQ? m n)))
;LE? (L m n (NOT (GEQ? m n)))
LE? (L m n (NOT (LEQ? n m)))
; can be used to determine sign for the integers?
ABS (L a b (LEQ? (SUB a b) (SUB b a) (SUB b a) (SUB a b)))
PAIR (L a b s [s a b])
HEAD (L s [s TRUE])
TAIL (L s [s FALSE])
NIL (L x TRUE)
EMPTY (PAIR NIL NIL)
EMPTY? (L l (TAIL l (L h (L t FALSE))))
NIL? ZERO?
INDEX (L i l (HEAD [(i TAIL) l]))
PREPEND PAIR
FIRST HEAD
SECOND (L l (HEAD (TAIL l)))
THIRD (L l (HEAD (TAIL (TAIL l))))
SELF (L f x [f f x])
YCOMB (L f [(L x [x x]) (L y [f [y y]])])
GET (YCOMB (L f l n [ZERO? n (HEAD l) (, f (TAIL l) (PRED n))]))
LEN (YCOMB (L f l [(EMPTY? l) ZERO (SUM ONE [f (TAIL l)])]))
LAST (YCOMB (L f l (EMPTY? (TAIL l) (HEAD l) [f (TAIL l)])))
; EXTEND LIST LIST
EXTEND (YCOMB (L g a b [(EMPTY? a) b (PAIR (HEAD a) [g (TAIL a) b])]))
; APPEND LIST item
APPEND (YCOMB (L g a b [(EMPTY? a) (PAIR b EMPTY) (PAIR (HEAD a) [g (TAIL a) b])]))
;APPEND EXTEND
MAP (YCOMB (L g f x [(EMPTY? x) EMPTY (PAIR [f (HEAD x)] [g f (TAIL x)])]))
FOLD-LEFT (YCOMB (L g f e x [(EMPTY? x) e [g f [f e (HEAD x)] (TAIL x)]]))
FOLD-RIGHT (L f e x [YCOMB (L g y [(EMPTY? y) e [f (HEAD y) [g (TAIL y)]]]) x])
;
REVERSE (YCOMB (L g a l [(EMPTY? l) a [g (PAIR (HEAD l) a) (TAIL l)]]) EMPTY)
;
APPLY (YCOMB (L g f x [(EMPTY? x) f [g [f (HEAD x)] (TAIL x)]]))
;TRUNCATE (LIST ONE TWO THREE) -> (LIST ONE TWO)
TRUNCATE (YCOMB (L g x [EMPTY? x EMPTY [EMPTY? (TAIL x) EMPTY (PAIR (HEAD x) [g (TAIL x)])]]))
; RANGE ONE FOUR -> (LIST ONE TWO THREE)
RANGE (L s e (YCOMB (L g c [LE? c e (PAIR c [g (SUCC c)]) EMPTY]) s))
; FILTER ZERO? (LIST ONE ZERO ONE ZERO ONE) -> (LIST ZERO ZERO)
FILTER (YCOMB (L g f x [EMPTY? x EMPTY [f (HEAD x) (PAIR (HEAD x)) IDENT [g f (TAIL x)]]]))
; CROSS PAIR (LIST ONE TWO) (LIST THREE FOUR) ->
; (LIST (PAIR ONE THREE) (PAIR ONE FOUR) (PAIR TWO THREE) (PAIR TWO FOUR))
CROSS (L f l m [FOLD-LEFT EXTEND EMPTY (MAP (L x (MAP [f x] m)) l)])
; ZIP (LIST ONE THREE) (LIST TWO FOUR) -> (LIST (PAIR ONE TWO) (PAIR THREE FOUR))
ZIP (YCOMB (L f l m [EMPTY? l EMPTY (PAIR (PAIR (HEAD l) (HEAD m)) [f (TAIL l) (TAIL m)])]))
; (LIST* THREE ONE TWO THREE)
LIST* (L n [n (L f a x [f (PAIR x a)]) REVERSE EMPTY])
; (DIV FIVE THREE) -> PAIR IDIV MOD -> (ONE TWO)
DIV (YCOMB (L g q a b (LEQ? a b (PAIR q a) [g (SUCC q) (SUB b a) b])) ZERO)
; (IDIV FIVE THREE) -> ONE
IDIV (L a b [HEAD [DIV a b]])
; (MOD FIVE THREE) -> TWO
MOD (L a b [TAIL [DIV a b]])
; greatest common divisor: (GCD 54 48) -> 6
GCD ((L g m n [LEQ? m n [g n m] [g m n]]) [YCOMB (L g x y [ZERO? y x [g y [MOD x y]]])])
; 1 + 2 + 3 + ... + n
SUMMATION (L n (YCOMB (L f n [(ZERO? n) n (SUM n [f (PRED n)])]) n))
; 1 * 2 * 3 * ... * n
FACTORIAL (L n (YCOMB (L f n [(ZERO? n) ONE (PROD n [f (PRED n)])]) n))
; Fn = F(n-1) + F(n-2)
;FIBONACCI (L n (YCOMB (L f n [(ZERO? n) ONE (SUM [f (PRED n)] [f (PRED (PRED n))])]) (PRED n)))
; excludes the first two seed numbers
FIBONACCI (L n (YCOMB (L f n [(LEQ? n TWO) n (SUM [f (PRED n)] [f (PRED (PRED n))])]) n))
; erastotenes prime sieve
PRIME? (L m [NOT [FOLD-LEFT OR FALSE (MAP (L n [ZERO? [MOD m n]]) (RANGE TWO m))]])
PRIMES (L m n (FILTER PRIME? (RANGE m (SUCC n))))
; compute real digits, decimal expansion by: numerator denominator number-base limit
; (DIGITS (NUM 1) (NUM 7) (NUM 10) (NUM 6)) -> 0 1 4 2 8 5 7
DIGITS (L l m n o [YCOMB (L f p q
(ZERO? q EMPTY (PAIR (HEAD p) [f [DIV (PROD (TAIL p) n) m] (PRED q)]))) [DIV l m] o])
)
(defn N [m]
(def n ZERO)
(while (pos? m)
(def n (SUCC n) m (dec m))) n)
(defn NM [n &optional [m FALSE]]
(while (> n 0)
(def n (dec n) m (SUCC m))) m)
(defn FLAT [l]
(while (not (MUN (EMPTY? l)))
(do (yield (FIRST l))
(def l (TAIL l)))))
(defn LIST [&rest args]
(reduce (fn [y x] (PAIR x y)) (reverse (list args)) EMPTY))
; integers
; -4 -> (PAIR FALSE FOUR)
(defmacro ℤ+ [number] `(PAIR TRUE #ℕ~number))
(defmacro ℤ- [number] `(PAIR FALSE #ℕ~number))
(defsharp ℤ [number] (if (pos? number) `(ℤ+ ~number) `(ℤ- ~number)))
; rational numbers
; could be formed with DIV too (PAIR TRUE/FALSE (PAIR denominator (PAIR IDIV MOD))) ->
; +/- ((denominator * IDIV) + MOD / denominator)
; -1/7 -> (PAIR FALSE (PAIR ONE SEVEN))
(defmacro ℚ+ [number] `(PAIR TRUE (PAIR #ℕ~(second number) #ℕ~(last number))))
(defmacro ℚ- [number] `(PAIR FALSE (PAIR #ℕ~(second number) #ℕ~(last number))))
(defsharp ℚ [number]
`(PAIR (if (pos? ~number) TRUE FALSE)
(PAIR #ℕ~(second number) #ℕ~(last number))))
; imaginary numbers
; #ℂ-0.5+2j -> (PAIR (PAIR FALSE (PAIR ONE TWO)) (PAIR TRUE (PAIR TWO ONE)))
(defsharp ℂ [number]
(import (fractions [Fraction]))
(def real (Fraction (abs number.real))
imag (Fraction (abs number.imag)))
`(do
(PAIR
(PAIR (if (pos? ~number.real) TRUE FALSE)
(PAIR (NUM ~real.numerator) (NUM ~real.denominator)))
(PAIR (if (pos? ~number.imag) TRUE FALSE)
(PAIR (NUM ~imag.numerator) (NUM ~imag.denominator))))))
Out[4]:
In [5]:
; functional way of constructing place value encoded church numerals
(defn N* [n]
(def a (list (map int (str n)))
b EMPTY)
(while a
; note than N uses SUCC lambda function to construct the numeral
(def b (PAIR (N (int (.pop a 0))) b))) b)
; macro way of constructing place value encoded church numerals
(defmacro NUM* [n]
(with-gensyms [a b]
(def a (list (map int (str n)))
b `EMPTY)
(while a
(def b `(PAIR (NUM ~(int (.pop a 0))) ~b))) b))
; converting value position numerals to native ones
; for base 10 normal number is shown
; for other bases the list of items is returned
(defn MUN* [n &optional [base 10]]
(def n (list (map MUN (FLAT n)))
o 0)
(if (= base 10)
(do
(for [[l m] (enumerate n)]
(def o (+ o (* m (pow base l))))) o) n))
; a simple way of summing up place value encoded church numerals
(def SUM** (YCOMB (L f c d (AND (EMPTY? c) (EMPTY? d) EMPTY (PAIR (SUM (HEAD c) (HEAD d)) (, f (TAIL c) (TAIL d)))))))
; More comprehensive way of implementing the sum function for the place value encoded church numerals.
; Basicly, when summing two values in place, use DIV to find out integer and numerator part of the summed
; values relative to their base. Possible leftover is moved to the next slot and finally, if needed,
; algorithm creates a new slot for the multitude exceeding summed ones.
; For example, 4 and 5 are encoded by place value church numerals to tuples: (PAIR 4 EMPTY) and (PAIR 5 EMPTY)
; Now, when numbers are summed up they would form: (PAIR 9 EMPTY) where MEPTY is a (PAIR NIL NIL) to indicate the
; end of the list. For another example 9 + 9 would be (PAIR 18 EMPTY) in the simple implementation, but
; here on the actual algorithm integer part 1 is moved forward to the next place and the result is:
; (PAIR 8 (PAIR 1 EMPTY)). Remember that by definition place value numbers are encoded so that the first item is
; the 10^0 part, second 10^1, and so forth.
; (def SUM* (L a b s [ZERO*? a b [YCOMB (L f c d [ZERO*? c d (, f (PRED* c s) (SUCC* d s))]) a b]]))
(def SUM*
; number a and number b for base s
(L a b s [YCOMB
; if both tails of the numbers a and b reaches the end
(L f a b e (AND (EMPTY? a) (EMPTY? b)
; if integer part of the number e is zero return numerator of e with end of the tuple
(ZERO? (HEAD e) (PAIR (TAIL e) EMPTY)
; else take both the numerator and the integer part and return them with the end of the tuple
(PAIR (TAIL e) (PAIR (HEAD e) EMPTY)))
; proceed with the rest of the numerals by constructing the tuple from the numerator part of the e
; and recursively call sum* with new tails (possibly empty)
(PAIR (TAIL e) [f (EMPTY? a EMPTY (TAIL a)) (EMPTY? b EMPTY (TAIL b))
; and the new idiv and mod taken from the sum of the previous idiv and
; sum of the current idiv's of the number a and b
[DIV (SUM (HEAD e) (SUM (EMPTY? a ZERO (HEAD a)) (EMPTY? b ZERO (HEAD b)))) s]])))
; pass only tails of the number a and b because the first digit is already pre-calculated here with DIV
; this is to prevent duplicate code inside y-combinator function
(TAIL a) (TAIL b) [DIV (SUM (HEAD a) (HEAD b)) s]]))
; successor function based on SUM*
;(def SUCC* (L n s [SUM* (NUM* 1) n s]))
(def ZERO* (NUM* 0)
ONE* (NUM* 1)
SUCC* (L n s [YCOMB (L f a b (EMPTY? a ONE*
(LEQ? (FIRST a) b
(PAIR (SUCC (FIRST a)) (TAIL a))
(PAIR ZERO (, f (TAIL a) b))))) n (PRED s)]))
; substract the place value number a from b in base s
; (def SUB* (L a b s [YCOMB (L f c d (ZERO*? c d (, f (PRED* c s) (PRED* d s)))) a b]))
(def SUB* (L a b s [YCOMB (L f a b (EMPTY? b EMPTY
(LEQ? (HEAD a) (HEAD b)
; if number a is smaller or same as b, we can safely substract them in that order
(PAIR (SUB (HEAD a) (HEAD b))
; if there are no more number slots in a, generate a zero slot to use it against b
[f (EMPTY? (TAIL a) (PAIR ZERO EMPTY) (TAIL a)) (TAIL b)])
; if a is greater than b, then add base s to b and substract only after that
(PAIR (SUB (HEAD a) (SUM (HEAD b) s))
; if there are no more number slots, generate a slot with number one.
; on other case get the successor of number a to make correct substraction on the next number slots
[f (EMPTY? (TAIL a) (PAIR ONE EMPTY) [SUCC* (TAIL a) s]) (TAIL b)]))))
;[f (EMPTY? (TAIL a) (PAIR ONE EMPTY) (PAIR (SUCC (HEAD (TAIL a))) (TAIL (TAIL a)))) (TAIL b)]))))
a b]))
; predecessor function based on SUB*
(def ;PRED* (L n s [SUB* (NUM* 1) n s])
ZERO*? (L n (AND (EMPTY? (TAIL n)) (ZERO? (HEAD n))))
PRED* (L n s [YCOMB (L f a b (ZERO? (HEAD a)
(EMPTY? (TAIL (TAIL a))
[LEQ? ZERO (SECOND a) (APPEND b (PRED (SECOND a))) b]
[EXTEND b [f (TAIL a) b]])
(PAIR (PRED (HEAD a)) (TAIL a)))) n (LIST (PRED s))]))
(def ; integer and remainder part are stored in reverse order and as a list format
; this simplifies extending lists in PROD*
DIV* (YCOMB (L g q a b (LEQ? a b (PAIR a (PAIR q EMPTY)) [g (SUCC q) (SUB b a) b])) ZERO)
; multiply the place value number a with b in base s
PROD* (L a b s [YCOMB (L f l m n o p
[AND (EMPTY? l) (EMPTY? (TAIL m))
; if both numbers has reached tails, extend current mod with the latest one
; if the latest mod remainder is bigger than 0
(EXTEND o (ZERO? (SECOND p) (PAIR (FIRST p) EMPTY) p))
[EMPTY? l
; concatenate result with the current remainder
(PAIR (HEAD o)
; and process with a new fresh a with the tail of m. the latest mod becomes additions
; on the next round
[f a (TAIL m) (EXTEND (TAIL o) p) EMPTY EMPTY])
; more forward with l, and pass the tail of n. process the current remainders and the latest mod
[f (TAIL l) m (EMPTY? n n (TAIL n)) (EMPTY? p o (APPEND o (HEAD p)))
; latest mod is created by summing the product of l and m with the addional n and the latest mod p
[DIV* (SUM (PROD (HEAD l) (HEAD m)) (SUM (EMPTY? n ZERO (HEAD n)) (EMPTY? p ZERO (SECOND p)))) s]
;[SUM* [DIV* (PROD (HEAD l) (HEAD m)) s]
; [DIV* (SUM (EMPTY? n ZERO (HEAD n)) (EMPTY? p ZERO (SECOND p))) s] s]
]]])
; call recursive function with default values
a b EMPTY EMPTY EMPTY]))
; multiply the place value number a with b in base s
;(def EXP* (L a b s [YCOMB (L f a b (ZERO*? b ONE* [PROD* a (, f a (PRED* b s)) s])) a b]))
(def EXP* (L a b s [YCOMB (L f a b (ZERO? b ONE* [PROD* a (, f a (PRED b)) s])) a b]))
Out[5]:
In [6]:
(defn pred [n &optional [base 10]]
(defn _ [a b]
; if the first item of the list one or more
(if (first a)
; decrease the first by one and return the list
(+ [(dec (first a))] (cut a 1))
; the first item on the list is zero but there are more than two items
; so we need to deal with all the rest
(if (cut a 2)
; return the base-1 as the first item and scan the rest of the list
(+ b (_ (cut a 1) b))
; there are only two items on the list, the first item is zero and the second item
; is greater than one -> change the first item that is zero to base minus one,
; i.e.e 9 in base 10 and decrease the second item by one
(if (< 1 (second a)) (+ b [(dec (second a))])
; in other cases return base-1
b))))
(_ n [(dec base)]))
(defn zero*? [n]
(and (not (cut n 1)) (not (first n))))
(defn subs [a b &optional [base 10]]
(defn _ [c d]
(if (zero*? c) d
(_ (pred c base) (pred d base))))
(_ a b))
(defn succ [n &optional [base 10]]
(defn _ [a b]
; if the list is empty, return list with the first item
; note that in base 2 the max value is exactly 1, so the minimum base given can be 2
(if (not a) [1]
; if the first item in list a is less than base-1
(if (< (first a) b)
; increase the first digit and return the rest of the list intact
(+ [(inc (first a))] (cut a 1))
; add zero to the list and append the rest of the list recursively modified
(+ [0] (_ (cut a 1) b)))))
(_ n (dec base)))
(defn summ [a b &optional [base 10]]
(defn _ [c d]
(if (zero*? d) c
(_ (succ c base) (pred d base))))
(_ a b))
(defn div [n &optional [base 10]]
[(% n base) (// n base)])
(defn mult [a b &optional [base 10]]
(defn _ [c d f g e]
(if (and (not b) (not c))
(do (print g)(+ g (if (second e) e (cut e 0 1))))
(if c
(_ (cut c 1) d f (if e (+ g (cut e 0 1)) g)
(div (+ (* (first c) d) (if e (second e) 0) (if f (f.pop 0) 0)) base))
(+ (cut g 0 1) (_ a (b.pop 0) (+ (cut g 1) e) [] [])))))
(_ a (b.pop 0) [] [] []))
In [ ]: