mirror of
https://github.com/kanaka/mal.git
synced 2024-09-19 01:28:26 +03:00
Merge pull request #371 from asarhaddon/extend-core.mal
Extend core.mal
This commit is contained in:
Joel Martin
GitHub
commit
a4cb289ffb
66
core.mal
66
core.mal
@ -1,66 +0,0 @@
|
||||
(def! dec (fn* (a) (- a 1)))
|
||||
|
||||
(def! zero? (fn* (n) (= 0 n)))
|
||||
|
||||
(def! reduce
|
||||
(fn* (f init xs)
|
||||
(if (empty? xs)
|
||||
init
|
||||
(reduce f (f init (first xs)) (rest xs)))))
|
||||
|
||||
(def! identity (fn* (x) x))
|
||||
|
||||
(def! every?
|
||||
(fn* (pred xs)
|
||||
(if (empty? xs)
|
||||
true
|
||||
(if (pred (first xs))
|
||||
(every? pred (rest xs))
|
||||
false))))
|
||||
|
||||
(def! some
|
||||
(fn* (pred xs)
|
||||
(if (empty? xs)
|
||||
nil
|
||||
(let* (res (pred (first xs)))
|
||||
(if res
|
||||
res
|
||||
(some pred (rest xs)))))))
|
||||
|
||||
(defmacro! and
|
||||
(fn* (& xs)
|
||||
(if (empty? xs)
|
||||
true
|
||||
(if (= 1 (count xs))
|
||||
(first xs)
|
||||
(let* (condvar (gensym))
|
||||
`(let* (~condvar ~(first xs))
|
||||
(if ~condvar (and ~@(rest xs)) ~condvar)))))))
|
||||
|
||||
(defmacro! ->
|
||||
(fn* (x & xs)
|
||||
(if (empty? xs)
|
||||
x
|
||||
(let* (form (first xs)
|
||||
more (rest xs))
|
||||
(if (empty? more)
|
||||
(if (list? form)
|
||||
`(~(first form) ~x ~@(rest form))
|
||||
(list form x))
|
||||
`(-> (-> ~x ~form) ~@more))))))
|
||||
|
||||
(defmacro! ->>
|
||||
(fn* (x & xs)
|
||||
(if (empty? xs)
|
||||
x
|
||||
(let* (form (first xs)
|
||||
more (rest xs))
|
||||
(if (empty? more)
|
||||
(if (list? form)
|
||||
`(~(first form) ~@(rest form) ~x)
|
||||
(list form x))
|
||||
`(->> (->> ~x ~form) ~@more))))))
|
||||
|
||||
; This `nil` is intentional so that the result of doing `load-file` is
|
||||
; `nil` instead of whatever happens to be at the end of `core.mal`.
|
||||
nil
|
||||
@ -5,9 +5,7 @@ Then refresh the .png files.
|
||||
|
||||
General:
|
||||
- add chat bot for #mal
|
||||
- move tokenizer.mal and reader.mal from malc along with
|
||||
./examples/{equality,memoize,pprint,protocols}.mal and
|
||||
./core.mal to ./lib directory
|
||||
- move tokenizer.mal and reader.mal from malc to ./lib directory
|
||||
|
||||
- Finish guide.md
|
||||
- mention that identifier names are suggested. some have run
|
||||
|
||||
@ -1,41 +0,0 @@
|
||||
|
||||
(def! spaces- (fn* [indent]
|
||||
(if (> indent 0)
|
||||
(str " " (spaces- (- indent 1)))
|
||||
"")))
|
||||
|
||||
(def! pp-seq- (fn* [obj indent]
|
||||
(let* [xindent (+ 1 indent)]
|
||||
(apply str (pp- (first obj) 0)
|
||||
(map (fn* [x] (str "\n" (spaces- xindent)
|
||||
(pp- x xindent)))
|
||||
(rest obj))))))
|
||||
|
||||
(def! pp-map- (fn* [obj indent]
|
||||
(let* [ks (keys obj)
|
||||
kindent (+ 1 indent)
|
||||
kwidth (count (seq (str (first ks))))
|
||||
vindent (+ 1 (+ kwidth kindent))]
|
||||
(apply str (pp- (first ks) 0)
|
||||
" "
|
||||
(pp- (get obj (first ks)) 0)
|
||||
(map (fn* [k] (str "\n" (spaces- kindent)
|
||||
(pp- k kindent)
|
||||
" "
|
||||
(pp- (get obj k) vindent)))
|
||||
(rest (keys obj)))))))
|
||||
|
||||
(def! pp- (fn* [obj indent]
|
||||
(cond
|
||||
(list? obj) (str "(" (pp-seq- obj indent) ")")
|
||||
(vector? obj) (str "[" (pp-seq- obj indent) "]")
|
||||
(map? obj) (str "{" (pp-map- obj indent) "}")
|
||||
:else (pr-str obj))))
|
||||
|
||||
(def! pprint (fn* [obj]
|
||||
(println (pp- obj 0))))
|
||||
|
||||
|
||||
;;(pprint '(7 8 9 "ten" [11 12 [13 14]] 15 16))
|
||||
;;(pprint '{:abc 123 :def {:ghi 456 :jkl [789 "ten eleven twelve"]}})
|
||||
;;(pprint '(7 8 {:abc 123 :def {:ghi 456 :jkl 789}} 9 10 [11 12 [13 14]] 15 16))
|
||||
@ -1,70 +0,0 @@
|
||||
;; A sketch of Clojure-like protocols, implemented in Mal
|
||||
;; By chouser (Chris Houser)
|
||||
;; Original: https://gist.github.com/Chouser/6081ea66d144d13e56fc
|
||||
|
||||
(def! builtin-type (fn* [obj]
|
||||
(cond
|
||||
(list? obj) :mal/list
|
||||
(vector? obj) :mal/vector
|
||||
(map? obj) :mal/map
|
||||
(symbol? obj) :mal/symbol
|
||||
(keyword? obj) :mal/keyword
|
||||
(atom? obj) :mal/atom
|
||||
(nil? obj) nil
|
||||
(true? obj) :mal/bool
|
||||
(false? obj) :mal/bool)))
|
||||
|
||||
(def! find-protocol-methods (fn* [protocol obj]
|
||||
(let* [p @protocol]
|
||||
(or (get p (get (meta obj) :type))
|
||||
(get p (builtin-type obj))
|
||||
(get p :mal/default)))))
|
||||
|
||||
(def! satisfies? (fn* [protocol obj]
|
||||
(if (find-protocol-methods protocol obj) true false)))
|
||||
|
||||
(defmacro! defprotocol (fn* [proto-name & methods]
|
||||
`(do
|
||||
(def! ~proto-name (atom {}))
|
||||
~@(map (fn* [m]
|
||||
(let* [name (first m), sig (first (rest m))]
|
||||
`(def! ~name (fn* [this-FIXME & args-FIXME]
|
||||
(apply (get (find-protocol-methods ~proto-name this-FIXME)
|
||||
~(keyword (str name)))
|
||||
this-FIXME args-FIXME)))))
|
||||
methods))))
|
||||
|
||||
(def! extend (fn* [type proto methods & more]
|
||||
(do
|
||||
(swap! proto assoc type methods)
|
||||
(if (first more)
|
||||
(apply extend type more)))))
|
||||
|
||||
;;----
|
||||
;; Example:
|
||||
|
||||
(def! make-triangle (fn* [o a]
|
||||
^{:type :shape/triangle} {:opposite o, :adjacent a}))
|
||||
|
||||
(def! make-rectangle (fn* [x y]
|
||||
^{:type :shape/rectangle} {:width x, :height y}))
|
||||
|
||||
(defprotocol IDraw
|
||||
(area [this])
|
||||
(draw [this]))
|
||||
|
||||
(prn :false-> (satisfies? IDraw (make-triangle 5 5))) ;=> false
|
||||
|
||||
(extend :shape/rectangle
|
||||
IDraw
|
||||
{:area (fn* [obj] (* (get obj :width) (get obj :height)))
|
||||
:draw (fn* [obj] (println "[]"))})
|
||||
|
||||
(extend :shape/triangle
|
||||
IDraw
|
||||
{:area (fn* [obj] (/ (* (get obj :opposite) (get obj :adjacent)) 2))
|
||||
:draw (fn* [obj] (println " .\n.."))})
|
||||
|
||||
(prn :true-> (satisfies? IDraw (make-triangle 5 5))) ;=> true
|
||||
|
||||
(prn :area-> (area (make-triangle 5 4))) ;=> 10
|
||||
29
lib/README.md
Normal file
29
lib/README.md
Normal file
@ -0,0 +1,29 @@
|
||||
This directory contains general-purpose reusable code that does not
|
||||
fit in the process.
|
||||
|
||||
The split in small files is motivated by implementations too limited
|
||||
to load a single big file, but MAL has no proper module management.
|
||||
|
||||
However, here are some guidelines.
|
||||
|
||||
- Begin with an one-line ;; short description
|
||||
|
||||
- End with `nil`, so that the result of `load-file` is conveniently
|
||||
short when loading manually and predictilbe for automatic testing
|
||||
|
||||
- Describe the restrictions on each parameter in comments.
|
||||
|
||||
- Define private symbols in hidden environments when possible. If this
|
||||
is not possible, for example for macros, give them a name starting
|
||||
with an underscore.
|
||||
|
||||
- Support successive imports safely by giving the same definitions
|
||||
again.
|
||||
|
||||
If a module provides tests, you may run against an implementation IMPL
|
||||
with these commands.
|
||||
```
|
||||
make IMPL^stepA
|
||||
cd tests
|
||||
python ../runtest.py lib/MODULE.mal ../IMPL/run
|
||||
```
|
||||
@ -1,60 +1,58 @@
|
||||
;;
|
||||
;; equality.mal
|
||||
;;
|
||||
|
||||
;; This file checks whether the `=` function correctly implements equality of
|
||||
;; hash-maps and sequences (lists and vectors). If not, it redefines the `=`
|
||||
;; function with a pure mal (recursive) implementation that only relies on the
|
||||
;; native original `=` function for comparing scalars (integers, booleans,
|
||||
;; symbols, strings).
|
||||
;;
|
||||
;; symbols, strings, keywords, atoms, nil).
|
||||
|
||||
;; Save the original (native) `=` as scalar-equal?
|
||||
(def! scalar-equal? =)
|
||||
|
||||
;; A simple `and` macro for two argument which doesn't use `=` internally
|
||||
(defmacro! and2
|
||||
(fn* [a b]
|
||||
`(let* (and2_FIXME ~a)
|
||||
(if and2_FIXME ~b and2_FIXME))))
|
||||
;; A faster `and` macro which doesn't use `=` internally.
|
||||
(defmacro! and2 ; boolean
|
||||
(fn* [& xs] ; interpreted as logical values
|
||||
(if (empty? xs)
|
||||
true
|
||||
`(if ~(first xs) (and2 ~@(rest xs)) false))))
|
||||
(defmacro! or2 ; boolean
|
||||
(fn* [& xs] ; interpreted as logical values
|
||||
(if (empty? xs)
|
||||
false
|
||||
`(if ~(first xs) true (or2 ~@(rest xs))))))
|
||||
|
||||
;; Implement `=` for two sequential arguments
|
||||
(def! sequential-equal?
|
||||
(def! starts-with?
|
||||
(fn* [a b]
|
||||
(if (scalar-equal? (count a) (count b))
|
||||
(if (empty? a)
|
||||
true
|
||||
(if (mal-equal? (first a) (first b))
|
||||
(sequential-equal? (rest a) (rest b))
|
||||
false))
|
||||
false)))
|
||||
(or2 (empty? a)
|
||||
(and2 (mal-equal? (first a) (first b))
|
||||
(starts-with? (rest a) (rest b))))))
|
||||
|
||||
;; Helper function
|
||||
(def! hash-map-vals-equal?
|
||||
(fn* [a b map-keys]
|
||||
(if (scalar-equal? 0 (count map-keys))
|
||||
true
|
||||
(let* [key (first map-keys)]
|
||||
(if (and2
|
||||
(and2 (contains? a key) (contains? b key))
|
||||
(mal-equal? (get a key) (get b key)))
|
||||
(hash-map-vals-equal? a b (rest map-keys))
|
||||
false)))))
|
||||
|
||||
;; Implement `=` for two hash-maps
|
||||
(def! hash-map-equal?
|
||||
(fn* [a b]
|
||||
(let* [keys-a (keys a)]
|
||||
(if (scalar-equal? (count keys-a) (count (keys b)))
|
||||
(hash-map-vals-equal? a b keys-a)
|
||||
false))))
|
||||
(or2 (empty? map-keys)
|
||||
(let* [key (first map-keys)]
|
||||
(and2 (contains? b key)
|
||||
(mal-equal? (get a key) (get b key))
|
||||
(hash-map-vals-equal? a b (rest map-keys)))))))
|
||||
|
||||
;; This implements = in pure mal (using only scalar-equal? as native impl)
|
||||
(def! mal-equal?
|
||||
(fn* [a b]
|
||||
(cond
|
||||
(and2 (sequential? a) (sequential? b)) (sequential-equal? a b)
|
||||
(and2 (map? a) (map? b)) (hash-map-equal? a b)
|
||||
true (scalar-equal? a b))))
|
||||
|
||||
(sequential? a)
|
||||
(and2 (sequential? b)
|
||||
(scalar-equal? (count a) (count b))
|
||||
(starts-with? a b))
|
||||
|
||||
(map? a)
|
||||
(let* [keys-a (keys a)]
|
||||
(and2 (map? b)
|
||||
(scalar-equal? (count keys-a) (count (keys b)))
|
||||
(hash-map-vals-equal? a b keys-a)))
|
||||
|
||||
true
|
||||
(scalar-equal? a b))))
|
||||
|
||||
(def! hash-map-equality-correct?
|
||||
(fn* []
|
||||
@ -76,3 +74,5 @@
|
||||
(do
|
||||
(def! = mal-equal?)
|
||||
(println "equality.mal: Replaced = with pure mal implementation")))
|
||||
|
||||
nil
|
||||
@ -1,16 +1,17 @@
|
||||
;;
|
||||
;; memoize.mal
|
||||
;;
|
||||
;; Memoize any function.
|
||||
|
||||
;; Implement `memoize` using an atom (`mem`) which holds the memoized results
|
||||
;; (hash-map from the arguments to the result). When the function is called,
|
||||
;; the hash-map is checked to see if the result for the given argument was already
|
||||
;; calculated and stored. If this is the case, it is returned immediately;
|
||||
;; otherwise, it is calculated and stored in `mem`.
|
||||
;;
|
||||
;; Adapted from http://clojure.org/atoms
|
||||
;;
|
||||
|
||||
;; Memoize any function
|
||||
;; For recursive functions, take care to store the wrapper under the
|
||||
;; same name than the original computation with an assignment like
|
||||
;; `(def! f (memoize f))`, so that intermediate results are memorized.
|
||||
|
||||
;; Adapted from http://clojure.org/atoms
|
||||
|
||||
(def! memoize
|
||||
(fn* [f]
|
||||
(let* [mem (atom {})]
|
||||
@ -23,31 +24,4 @@
|
||||
(swap! mem assoc key ret)
|
||||
ret))))))))
|
||||
|
||||
;; Naive (non-memoized) Fibonacci function
|
||||
(def! fib
|
||||
(fn* [n]
|
||||
(if (<= n 1)
|
||||
n
|
||||
(+ (fib (- n 1)) (fib (- n 2))))))
|
||||
|
||||
|
||||
;; -----------------------------------------------
|
||||
;; Benchmarks
|
||||
|
||||
(load-file "../perf.mal") ; for the 'time' macro
|
||||
(def! N 32)
|
||||
|
||||
;; Benchmark naive 'fib'
|
||||
|
||||
(println "fib N=" N ": without memoization:")
|
||||
(time (fib N))
|
||||
;; "Elapsed time: 14402 msecs"
|
||||
|
||||
|
||||
;; Benchmark memoized 'fib'
|
||||
|
||||
(def! fib (memoize fib))
|
||||
|
||||
(println "fib N=" N ": with memoization:")
|
||||
(time (fib N))
|
||||
;; "Elapsed time: 1 msecs"
|
||||
nil
|
||||
40
lib/perf.mal
Normal file
40
lib/perf.mal
Normal file
@ -0,0 +1,40 @@
|
||||
;; Mesure performances.
|
||||
|
||||
;; Evaluate an expression, but report the time spent
|
||||
(defmacro! time
|
||||
(fn* (exp)
|
||||
(let* [start (gensym)
|
||||
ret (gensym)]
|
||||
`(let* [~start (time-ms)
|
||||
~ret ~exp]
|
||||
(do
|
||||
(prn (str "Elapsed time: " (- (time-ms) ~start) " msecs"))
|
||||
~ret)))))
|
||||
|
||||
;; Count evaluations of a function during a given time frame.
|
||||
(def! run-fn-for
|
||||
|
||||
(let* [
|
||||
run-fn-for* (fn* [fn max-ms acc-ms last-iters]
|
||||
(let* [start (time-ms)
|
||||
_ (fn)
|
||||
elapsed (- (time-ms) start)
|
||||
iters (+ 1 last-iters)
|
||||
new-acc-ms (+ acc-ms elapsed)]
|
||||
;; (do (prn "new-acc-ms:" new-acc-ms "iters:" iters))
|
||||
(if (>= new-acc-ms max-ms)
|
||||
last-iters
|
||||
(run-fn-for* fn max-ms new-acc-ms iters))))
|
||||
]
|
||||
|
||||
(fn* [fn max-secs]
|
||||
;; fn : function without parameters
|
||||
;; max-secs : number (seconds)
|
||||
;; return : number (iterations)
|
||||
(do
|
||||
;; Warm it up first
|
||||
(run-fn-for* fn 1000 0 0)
|
||||
;; Now do the test
|
||||
(run-fn-for* fn (* 1000 max-secs) 0 0)))))
|
||||
|
||||
nil
|
||||
45
lib/pprint.mal
Normal file
45
lib/pprint.mal
Normal file
@ -0,0 +1,45 @@
|
||||
;; Pretty printer a MAL object.
|
||||
|
||||
(def! pprint
|
||||
|
||||
(let* [
|
||||
|
||||
spaces- (fn* [indent]
|
||||
(if (> indent 0)
|
||||
(str " " (spaces- (- indent 1)))
|
||||
""))
|
||||
|
||||
pp-seq- (fn* [obj indent]
|
||||
(let* [xindent (+ 1 indent)]
|
||||
(apply str (pp- (first obj) 0)
|
||||
(map (fn* [x] (str "\n" (spaces- xindent)
|
||||
(pp- x xindent)))
|
||||
(rest obj)))))
|
||||
|
||||
pp-map- (fn* [obj indent]
|
||||
(let* [ks (keys obj)
|
||||
kindent (+ 1 indent)
|
||||
kwidth (count (seq (str (first ks))))
|
||||
vindent (+ 1 (+ kwidth kindent))]
|
||||
(apply str (pp- (first ks) 0)
|
||||
" "
|
||||
(pp- (get obj (first ks)) 0)
|
||||
(map (fn* [k] (str "\n" (spaces- kindent)
|
||||
(pp- k kindent)
|
||||
" "
|
||||
(pp- (get obj k) vindent)))
|
||||
(rest (keys obj))))))
|
||||
|
||||
pp- (fn* [obj indent]
|
||||
(cond
|
||||
(list? obj) (str "(" (pp-seq- obj indent) ")")
|
||||
(vector? obj) (str "[" (pp-seq- obj indent) "]")
|
||||
(map? obj) (str "{" (pp-map- obj indent) "}")
|
||||
:else (pr-str obj)))
|
||||
|
||||
]
|
||||
|
||||
(fn* [obj]
|
||||
(println (pp- obj 0)))))
|
||||
|
||||
nil
|
||||
97
lib/protocols.mal
Normal file
97
lib/protocols.mal
Normal file
@ -0,0 +1,97 @@
|
||||
;; A sketch of Clojure-like protocols, implemented in Mal
|
||||
|
||||
;; By chouser (Chris Houser)
|
||||
;; Original: https://gist.github.com/Chouser/6081ea66d144d13e56fc
|
||||
|
||||
;; This function maps a MAL value to a keyword representing its type.
|
||||
;; Most applications will override the default with an explicit value
|
||||
;; for the `:type` key in the metadata.
|
||||
(def! find-type (fn* [obj]
|
||||
(cond
|
||||
(symbol? obj) :mal/symbol
|
||||
(keyword? obj) :mal/keyword
|
||||
(atom? obj) :mal/atom
|
||||
(nil? obj) :mal/nil
|
||||
(true? obj) :mal/boolean
|
||||
(false? obj) :mal/boolean
|
||||
(number? obj) :mal/number
|
||||
(string? obj) :mal/string
|
||||
(macro? obj) :mal/macro
|
||||
true
|
||||
(let* [metadata (meta obj)
|
||||
type (if (map? metadata) (get metadata :type))]
|
||||
(cond
|
||||
(keyword? type) type
|
||||
(list? obj) :mal/list
|
||||
(vector? obj) :mal/vector
|
||||
(map? obj) :mal/map
|
||||
(fn? obj) :mal/function
|
||||
true (throw "unknown MAL value in protocols"))))))
|
||||
|
||||
;; A protocol (abstract class, interface..) is represented by a symbol.
|
||||
;; It describes methods (abstract functions, contracts, signals..).
|
||||
;; Each method is described by a sequence of two elements.
|
||||
;; First, a symbol setting the name of the method.
|
||||
;; Second, a vector setting its formal parameters.
|
||||
;; The first parameter is required, plays a special role.
|
||||
;; It is usually named `this` (`self`..).
|
||||
;; For example,
|
||||
;; (defprotocol protocol
|
||||
;; (method1 [this])
|
||||
;; (method2 [this argument]))
|
||||
;; can be thought as:
|
||||
;; (def! method1 (fn* [this]) ..)
|
||||
;; (def! method2 (fn* [this argument]) ..)
|
||||
;; (def! protocol ..)
|
||||
;; The return value is the new protocol.
|
||||
(defmacro! defprotocol (fn* [proto-name & methods]
|
||||
;; A protocol is an atom mapping a type extending the protocol to
|
||||
;; another map from method names as keywords to implementations.
|
||||
(let* [
|
||||
drop2 (fn* [args]
|
||||
(if (= 2 (count args))
|
||||
()
|
||||
(cons (first args) (drop2 (rest args)))))
|
||||
rewrite (fn* [method]
|
||||
(let* [
|
||||
name (first method)
|
||||
args (nth method 1)
|
||||
argc (count args)
|
||||
varargs? (if (<= 2 argc) (= '& (nth args (- argc 2))))
|
||||
dispatch `(get (get @~proto-name
|
||||
(find-type ~(first args)))
|
||||
~(keyword (str name)))
|
||||
body (if varargs?
|
||||
`(apply ~dispatch ~@(drop2 args) ~(nth args (- argc 1)))
|
||||
(cons dispatch args))
|
||||
]
|
||||
(list 'def! name (list 'fn* args body))))
|
||||
]
|
||||
`(do
|
||||
~@(map rewrite methods)
|
||||
(def! ~proto-name (atom {}))))))
|
||||
|
||||
;; A type (concrete class..) extends (is a subclass of, implements..)
|
||||
;; a protocol when it provides implementations for the required methods.
|
||||
;; (extend type protocol {
|
||||
;; :method1 (fn* [this] ..)
|
||||
;; :method2 (fn* [this arg1 arg2])})
|
||||
;; Additionnal protocol/methods pairs are equivalent to successive
|
||||
;; calls with the same type.
|
||||
;; The return value is `nil`.
|
||||
(def! extend (fn* [type proto methods & more]
|
||||
(do
|
||||
(swap! proto assoc type methods)
|
||||
(if (first more)
|
||||
(apply extend type more)))))
|
||||
|
||||
;; An object satisfies a protocol when its type extends the protocol,
|
||||
;; that is if the required methods can be applied to the object.
|
||||
(def! satisfies? (fn* [protocol obj]
|
||||
(contains? @protocol (find-type obj))))
|
||||
;; If `(satisfies protocol obj)` with the protocol below
|
||||
;; then `(method1 obj)` and `(method2 obj 1 2)`
|
||||
;; dispatch to the concrete implementation provided by the exact type.
|
||||
;; Should the type evolve, the calling code needs not change.
|
||||
|
||||
nil
|
||||
33
lib/reducers.mal
Normal file
33
lib/reducers.mal
Normal file
@ -0,0 +1,33 @@
|
||||
;; Left and right folds.
|
||||
|
||||
;; Left fold (f (.. (f (f init x1) x2) ..) xn)
|
||||
(def! reduce
|
||||
(fn* (f init xs)
|
||||
;; f : Accumulator Element -> Accumulator
|
||||
;; init : Accumulator
|
||||
;; xs : sequence of Elements x1 x2 .. xn
|
||||
;; return : Accumulator
|
||||
(if (empty? xs)
|
||||
init
|
||||
(reduce f (f init (first xs)) (rest xs)))))
|
||||
|
||||
;; Right fold (f x1 (f x2 (.. (f xn init)) ..))
|
||||
;; The natural implementation for `foldr` is not tail-recursive, so we
|
||||
;; rely on efficient `nth` and `count`.
|
||||
(def! foldr
|
||||
|
||||
(let* [
|
||||
rec (fn* [f xs acc index]
|
||||
(if (< index 0)
|
||||
acc
|
||||
(rec f xs (f (nth xs index) acc) (- index 1))))
|
||||
]
|
||||
|
||||
(fn* [f init xs]
|
||||
;; f : Element Accumulator -> Accumulator
|
||||
;; init : Accumulator
|
||||
;; xs : sequence of Elements x1 x2 .. xn
|
||||
;; return : Accumulator
|
||||
(rec f xs init (- (count xs) 1)))))
|
||||
|
||||
nil
|
||||
50
lib/test_cascade.mal
Normal file
50
lib/test_cascade.mal
Normal file
@ -0,0 +1,50 @@
|
||||
;; Iteration on evaluations interpreted as boolean values.
|
||||
|
||||
;; Conjonction of predicate values (pred x1) and .. and (pred xn)
|
||||
;; Evaluate `pred x` for each `x` in turn. Return `false` if a result
|
||||
;; is `nil` or `false`, without evaluating the predicate for the
|
||||
;; remaining elements. If all test pass, return `true`.
|
||||
(def! every?
|
||||
(fn* (pred xs)
|
||||
;; pred : Element -> interpreted as a logical value
|
||||
;; xs : sequence of Elements x1 x2 .. xn
|
||||
;; return : boolean
|
||||
(cond (empty? xs) true
|
||||
(pred (first xs)) (every? pred (rest xs))
|
||||
true false)))
|
||||
|
||||
;; Disjonction of predicate values (pred x1) or .. (pred xn)
|
||||
;; Evaluate `(pred x)` for each `x` in turn. Return the first result
|
||||
;; that is neither `nil` nor `false`, without evaluating the predicate
|
||||
;; for the remaining elements. If all tests fail, return nil.
|
||||
(def! some
|
||||
(fn* (pred xs)
|
||||
;; pred : Element -> interpreted as a logical value
|
||||
;; xs : sequence of Elements x1 x2 .. xn
|
||||
;; return : boolean
|
||||
(if (empty? xs)
|
||||
nil
|
||||
(or (pred (first xs))
|
||||
(some pred (rest xs))))))
|
||||
|
||||
;; Search for first evaluation returning `nil` or `false`.
|
||||
;; Rewrite `x1 x2 .. xn x` as
|
||||
;; (let* [r1 x1]
|
||||
;; (if r1 test1
|
||||
;; (let* [r2 x2]
|
||||
;; ..
|
||||
;; (if rn
|
||||
;; x
|
||||
;; rn) ..)
|
||||
;; r1))
|
||||
;; Without arguments, returns `true`.
|
||||
(defmacro! and
|
||||
(fn* (& xs)
|
||||
;; Arguments and the result are interpreted as boolean values.
|
||||
(cond (empty? xs) true
|
||||
(= 1 (count xs)) (first xs)
|
||||
true (let* (condvar (gensym))
|
||||
`(let* (~condvar ~(first xs))
|
||||
(if ~condvar (and ~@(rest xs)) ~condvar))))))
|
||||
|
||||
nil
|
||||
35
lib/threading.mal
Normal file
35
lib/threading.mal
Normal file
@ -0,0 +1,35 @@
|
||||
;; Composition of partially applied functions.
|
||||
|
||||
(load-file "../lib/reducers.mal") ; reduce
|
||||
|
||||
;; Rewrite x (a a1 a2) .. (b b1 b2) as
|
||||
;; (b (.. (a x a1 a2) ..) b1 b2)
|
||||
;; If anything else than a list is found were `(a a1 a2)` is expected,
|
||||
;; replace it with a list with one element, so that `-> x a` is
|
||||
;; equivalent to `-> x (list a)`.
|
||||
(defmacro! ->
|
||||
(fn* (x & xs)
|
||||
(reduce _iter-> x xs)))
|
||||
|
||||
(def! _iter->
|
||||
(fn* [acc form]
|
||||
(if (list? form)
|
||||
`(~(first form) ~acc ~@(rest form))
|
||||
(list form acc))))
|
||||
|
||||
;; Like `->`, but the arguments describe functions that are partially
|
||||
;; applied with *left* arguments. The previous result is inserted at
|
||||
;; the *end* of the new argument list.
|
||||
;; Rewrite x ((a a1 a2) .. (b b1 b2)) as
|
||||
;; (b b1 b2 (.. (a a1 a2 x) ..)).
|
||||
(defmacro! ->>
|
||||
(fn* (x & xs)
|
||||
(reduce _iter->> x xs)))
|
||||
|
||||
(def! _iter->>
|
||||
(fn* [acc form]
|
||||
(if (list? form)
|
||||
`(~(first form) ~@(rest form) ~acc)
|
||||
(list form acc))))
|
||||
|
||||
nil
|
||||
12
lib/trivial.mal
Normal file
12
lib/trivial.mal
Normal file
@ -0,0 +1,12 @@
|
||||
;; Trivial but convenient functions.
|
||||
|
||||
;; Integer predecessor (number -> number)
|
||||
(def! dec (fn* (a) (- a 1)))
|
||||
|
||||
;; Integer nullity test (number -> boolean)
|
||||
(def! zero? (fn* (n) (= 0 n)))
|
||||
|
||||
;; Returns the unchanged argument.
|
||||
(def! identity (fn* (x) x))
|
||||
|
||||
nil
|
||||
27
perf.mal
27
perf.mal
@ -1,27 +0,0 @@
|
||||
(defmacro! time
|
||||
(fn* (exp)
|
||||
`(let* (start_FIXME (time-ms)
|
||||
ret_FIXME ~exp)
|
||||
(do
|
||||
(prn (str "Elapsed time: " (- (time-ms) start_FIXME) " msecs"))
|
||||
ret_FIXME))))
|
||||
|
||||
(def! run-fn-for*
|
||||
(fn* [fn max-ms acc-ms last-iters]
|
||||
(let* [start (time-ms)
|
||||
_ (fn)
|
||||
elapsed (- (time-ms) start)
|
||||
iters (+ 1 last-iters)
|
||||
new-acc-ms (+ acc-ms elapsed)]
|
||||
;(do (prn "new-acc-ms:" new-acc-ms "iters:" iters))
|
||||
(if (>= new-acc-ms max-ms)
|
||||
last-iters
|
||||
(run-fn-for* fn max-ms new-acc-ms iters)))))
|
||||
|
||||
(def! run-fn-for
|
||||
(fn* [fn max-secs]
|
||||
(do
|
||||
;; Warm it up first
|
||||
(run-fn-for* fn 1000 0 0)
|
||||
;; Now do the test
|
||||
(run-fn-for* fn (* 1000 max-secs) 0 0))))
|
||||
19
tests/computations.mal
Normal file
19
tests/computations.mal
Normal file
@ -0,0 +1,19 @@
|
||||
;; Some inefficient arithmetic computations for benchmarking.
|
||||
|
||||
;; Unfortunately not yet available in tests of steps 4 and 5.
|
||||
|
||||
;; Compute n(n+1)/2 with a non tail-recursive call.
|
||||
(def! sumdown
|
||||
(fn* [n] ; non-negative number
|
||||
(if (= n 0)
|
||||
0
|
||||
(+ n (sumdown (- n 1))))))
|
||||
|
||||
;; Compute a Fibonacci number with two recursions.
|
||||
(def! fib
|
||||
(fn* [n] ; non-negative number
|
||||
(if (<= n 1)
|
||||
n
|
||||
(+ (fib (- n 1)) (fib (- n 2))))))
|
||||
|
||||
nil
|
||||
61
tests/lib/equality.mal
Normal file
61
tests/lib/equality.mal
Normal file
@ -0,0 +1,61 @@
|
||||
(def! orig= =)
|
||||
|
||||
;; Testing equality.mal does not fix built-in equality.
|
||||
(load-file "../lib/equality.mal")
|
||||
;=>nil
|
||||
|
||||
;; Testing and2
|
||||
(and2)
|
||||
;=>true
|
||||
(and2 true)
|
||||
;=>true
|
||||
(and2 false)
|
||||
;=>false
|
||||
(and2 nil)
|
||||
;=>false
|
||||
(and2 1)
|
||||
;=>true
|
||||
(and2 1 2)
|
||||
;=>true
|
||||
(and2 nil (nth () 1))
|
||||
;=>false
|
||||
|
||||
;; Testing or2
|
||||
(or2)
|
||||
;=>false
|
||||
(or2 true)
|
||||
;=>true
|
||||
(or2 false)
|
||||
;=>false
|
||||
(or2 nil)
|
||||
;=>false
|
||||
(or2 1)
|
||||
;=>true
|
||||
(or2 1 (nth () 1))
|
||||
;=>true
|
||||
(or2 1 2)
|
||||
;=>true
|
||||
(or2 false nil)
|
||||
;=>false
|
||||
|
||||
;; Breaking equality.
|
||||
(def! = (fn* [a b] (and2 (orig= a b) (cond (list? a) (list? b) (vector? a) (vector? b) true true))))
|
||||
(= [] ())
|
||||
;=>false
|
||||
|
||||
;; Testing that equality.mal detects the problem.
|
||||
(load-file "../lib/equality.mal")
|
||||
;/equality.mal: Replaced = with pure mal implementation
|
||||
;=>nil
|
||||
|
||||
;; Testing fixed equality.
|
||||
(= [] ())
|
||||
;=>true
|
||||
(= [:a :b] (list :a :b))
|
||||
;=>true
|
||||
(= [:a :b] [:a :b :c])
|
||||
;=>false
|
||||
(= {:a 1} {:a 1})
|
||||
;=>true
|
||||
(= {:a 1} {:a 1 :b 2})
|
||||
;=>false
|
||||
18
tests/lib/memoize.mal
Normal file
18
tests/lib/memoize.mal
Normal file
@ -0,0 +1,18 @@
|
||||
(load-file "../tests/computations.mal")
|
||||
;=>nil
|
||||
(load-file "../lib/memoize.mal")
|
||||
;=>nil
|
||||
|
||||
(def! N 32)
|
||||
|
||||
;; Benchmark naive 'fib'
|
||||
|
||||
(def! r1 (fib N)) ; Should be slow
|
||||
|
||||
;; Benchmark memoized 'fib'
|
||||
|
||||
(def! fib (memoize fib))
|
||||
(def! r2 (fib N)) ; Should be quick
|
||||
|
||||
(= r1 r2)
|
||||
;=>true
|
||||
38
tests/lib/pprint.mal
Normal file
38
tests/lib/pprint.mal
Normal file
@ -0,0 +1,38 @@
|
||||
(load-file "../lib/pprint.mal")
|
||||
;=>nil
|
||||
|
||||
(pprint '(7 8 9 "ten" [11 12 [13 14]] 15 16))
|
||||
;/\(7
|
||||
;/ 8
|
||||
;/ 9
|
||||
;/ "ten"
|
||||
;/ \[11
|
||||
;/ 12
|
||||
;/ \[13
|
||||
;/ 14\]\]
|
||||
;/ 15
|
||||
;/ 16\)
|
||||
;=>nil
|
||||
|
||||
(pprint '{:abc 123 :def {:ghi 456 :jkl [789 "ten eleven twelve"]}})
|
||||
;/\{:abc 123
|
||||
;/ :def \{:ghi 456
|
||||
;/ :jkl \[789
|
||||
;/ "ten eleven twelve"\]\}\}
|
||||
;=>nil
|
||||
|
||||
(pprint '(7 8 {:abc 123 :def {:ghi 456 :jkl 789}} 9 10 [11 12 [13 14]] 15 16))
|
||||
;/\(7
|
||||
;/ 8
|
||||
;/ \{:abc 123
|
||||
;/ :def \{:ghi 456
|
||||
;/ :jkl 789\}\}
|
||||
;/ 9
|
||||
;/ 10
|
||||
;/ \[11
|
||||
;/ 12
|
||||
;/ \[13
|
||||
;/ 14\]\]
|
||||
;/ 15
|
||||
;/ 16\)
|
||||
;=>nil
|
||||
80
tests/lib/protocols.mal
Normal file
80
tests/lib/protocols.mal
Normal file
@ -0,0 +1,80 @@
|
||||
(load-file "../lib/protocols.mal")
|
||||
;=>nil
|
||||
|
||||
;; Testing find-type for normal objects.
|
||||
(find-type 'a)
|
||||
;=>:mal/symbol
|
||||
(find-type :a)
|
||||
;=>:mal/keyword
|
||||
(find-type (atom 0))
|
||||
;=>:mal/atom
|
||||
(find-type nil)
|
||||
;=>:mal/nil
|
||||
(find-type true)
|
||||
;=>:mal/boolean
|
||||
(find-type false)
|
||||
;=>:mal/boolean
|
||||
(find-type 0)
|
||||
;=>:mal/number
|
||||
(find-type "")
|
||||
;=>:mal/string
|
||||
(find-type (defmacro! m (fn* [] nil)))
|
||||
;=>:mal/macro
|
||||
(find-type ())
|
||||
;=>:mal/list
|
||||
(find-type [])
|
||||
;=>:mal/vector
|
||||
(find-type {})
|
||||
;=>:mal/map
|
||||
(find-type (fn* [] nil))
|
||||
;=>:mal/function
|
||||
|
||||
;; Testing find-type for explicit type metadata.
|
||||
(find-type ^{:type :a } ())
|
||||
;=>:a
|
||||
(find-type ^{:type :a } [])
|
||||
;=>:a
|
||||
(find-type ^{:type :a } {})
|
||||
;=>:a
|
||||
(find-type ^{:type :a } (fn* [] nil))
|
||||
;=>:a
|
||||
|
||||
;; Testing protocols.
|
||||
(def! o1 ^{:type :t1 } [1])
|
||||
(def! o2 ^{:type :t2 } [2])
|
||||
(defprotocol p1 [m0 [this]] [ma [this a]] [mb [this & b]])
|
||||
(defprotocol p2)
|
||||
(satisfies? p1 o1)
|
||||
;=>false
|
||||
(satisfies? p1 o2)
|
||||
;=>false
|
||||
(satisfies? p2 o1)
|
||||
;=>false
|
||||
(satisfies? p2 o2)
|
||||
;=>false
|
||||
(extend :t1 p1 { :m0 (fn* [this] (str "t0" this)) :ma (fn* [this a] (str "ta" this a)) :mb (fn* [this & b] (str "tb" this b))})
|
||||
;=>nil
|
||||
(extend :t2 p1 { :m0 (fn* [this] (str "u0" this)) :ma (fn* [this a] (str "ua" this a)) :mb (fn* [this & b] (str "ub" this b))} p2 {})
|
||||
;=>nil
|
||||
(satisfies? p1 o1)
|
||||
;=>true
|
||||
(satisfies? p1 o2)
|
||||
;=>true
|
||||
(satisfies? p2 o1)
|
||||
;=>false
|
||||
(satisfies? p2 o2)
|
||||
;=>true
|
||||
|
||||
;; Testing dispatching.
|
||||
(m0 o1)
|
||||
;=>"t0[1]"
|
||||
(ma o1 "blue")
|
||||
;=>"ta[1]blue"
|
||||
(mb o1 1 2 3)
|
||||
;=>"tb[1](1 2 3)"
|
||||
(m0 o2)
|
||||
;=>"u0[2]"
|
||||
(ma o2 "blue")
|
||||
;=>"ua[2]blue"
|
||||
(mb o2 1 2 3)
|
||||
;=>"ub[2](1 2 3)"
|
||||
32
tests/lib/reducers.mal
Normal file
32
tests/lib/reducers.mal
Normal file
@ -0,0 +1,32 @@
|
||||
(load-file "../lib/reducers.mal")
|
||||
;=>nil
|
||||
|
||||
;; Testing reduce
|
||||
(reduce + 7 [])
|
||||
;=>7
|
||||
(reduce + 7 [1])
|
||||
;=>8
|
||||
(reduce + 7 [1 2])
|
||||
;=>10
|
||||
(reduce * 7 [-1 2])
|
||||
;=>-14
|
||||
(reduce concat [1] [[2] [3]])
|
||||
;=>(1 2 3)
|
||||
(reduce str "a" ["b" "c"])
|
||||
;=>"abc"
|
||||
|
||||
;; Testing foldr
|
||||
(foldr + 7 [])
|
||||
;=>7
|
||||
(foldr + 7 [1])
|
||||
;=>8
|
||||
(foldr + 7 [1 2])
|
||||
;=>10
|
||||
(reduce * 7 [-1 2])
|
||||
;=>-14
|
||||
(foldr concat [1] [[2] [3]])
|
||||
;=>(2 3 1)
|
||||
(foldr str "a" ["b" "c"])
|
||||
;=>"bca"
|
||||
(foldr cons [4 5] [2 3])
|
||||
;=>(2 3 4 5)
|
||||
27
tests/lib/test_cascade.mal
Normal file
27
tests/lib/test_cascade.mal
Normal file
@ -0,0 +1,27 @@
|
||||
(load-file "../lib/test_cascade.mal")
|
||||
;=>nil
|
||||
|
||||
;; Testing every?
|
||||
(every? first [])
|
||||
;=>true
|
||||
(every? first [[1] [2]])
|
||||
;=>true
|
||||
(every? first [[1] [nil] []])
|
||||
;=>false
|
||||
|
||||
;; Testing some
|
||||
(some first [])
|
||||
;=>nil
|
||||
(some first [[nil] [1] []])
|
||||
;=>1
|
||||
|
||||
(and)
|
||||
;=>true
|
||||
(and 1)
|
||||
;=>1
|
||||
(and 1 2 3 4)
|
||||
;=>4
|
||||
(and false 2)
|
||||
;=>false
|
||||
(and true 1 nil false)
|
||||
;=>nil
|
||||
22
tests/lib/threading.mal
Normal file
22
tests/lib/threading.mal
Normal file
@ -0,0 +1,22 @@
|
||||
(load-file "../lib/threading.mal")
|
||||
;=>nil
|
||||
|
||||
;; Testing -> macro
|
||||
(-> 7)
|
||||
;=>7
|
||||
(-> (list 7 8 9) first)
|
||||
;=>7
|
||||
(-> (list 7 8 9) (first))
|
||||
;=>7
|
||||
(-> (list 7 8 9) first (+ 7))
|
||||
;=>14
|
||||
(-> (list 7 8 9) rest (rest) first (+ 7))
|
||||
;=>16
|
||||
|
||||
;; Testing ->> macro
|
||||
(->> "L")
|
||||
;=>"L"
|
||||
(->> "L" (str "A") (str "M"))
|
||||
;=>"MAL"
|
||||
(->> [4] (concat [3]) (concat [2]) rest (concat [1]))
|
||||
;=>(1 3 4)
|
||||
11
tests/lib/trivial.mal
Normal file
11
tests/lib/trivial.mal
Normal file
@ -0,0 +1,11 @@
|
||||
(load-file "../lib/trivial.mal")
|
||||
;=>nil
|
||||
|
||||
(dec 12)
|
||||
;=>11
|
||||
(zero? 12)
|
||||
;=>false
|
||||
(zero? 0)
|
||||
;=>true
|
||||
(identity 12)
|
||||
;=>12
|
||||
@ -1,5 +1,6 @@
|
||||
(load-file "../core.mal")
|
||||
(load-file "../perf.mal")
|
||||
(load-file "../lib/threading.mal") ; ->
|
||||
(load-file "../lib/perf.mal") ; time
|
||||
(load-file "../lib/test_cascade.mal") ; or
|
||||
|
||||
;;(prn "Start: basic macros performance test")
|
||||
|
||||
|
||||
@ -1,11 +1,8 @@
|
||||
(load-file "../core.mal")
|
||||
(load-file "../perf.mal")
|
||||
(load-file "../tests/computations.mal") ; fib sumdown
|
||||
(load-file "../lib/perf.mal") ; time
|
||||
|
||||
;;(prn "Start: basic math/recursion test")
|
||||
|
||||
(def! sumdown (fn* (N) (if (> N 0) (+ N (sumdown (- N 1))) 0)))
|
||||
(def! fib (fn* (N) (if (= N 0) 1 (if (= N 1) 1 (+ (fib (- N 1)) (fib (- N 2)))))))
|
||||
|
||||
(time (do
|
||||
(sumdown 10)
|
||||
(fib 12)))
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
(load-file "../core.mal")
|
||||
(load-file "../perf.mal")
|
||||
(load-file "../lib/threading.mal") ; ->
|
||||
(load-file "../lib/perf.mal") ; run-fn-for
|
||||
(load-file "../lib/test_cascade.mal") ; or
|
||||
|
||||
;;(prn "Start: basic macros/atom test")
|
||||
|
||||
|
||||
@ -148,27 +148,3 @@ x
|
||||
|
||||
(let* [x (or nil "yes")] x)
|
||||
;=>"yes"
|
||||
|
||||
;;
|
||||
;; Loading core.mal
|
||||
(load-file "../core.mal")
|
||||
|
||||
;; Testing -> macro
|
||||
(-> 7)
|
||||
;=>7
|
||||
(-> (list 7 8 9) first)
|
||||
;=>7
|
||||
(-> (list 7 8 9) (first))
|
||||
;=>7
|
||||
(-> (list 7 8 9) first (+ 7))
|
||||
;=>14
|
||||
(-> (list 7 8 9) rest (rest) first (+ 7))
|
||||
;=>16
|
||||
|
||||
;; Testing ->> macro
|
||||
(->> "L")
|
||||
;=>"L"
|
||||
(->> "L" (str "A") (str "M"))
|
||||
;=>"MAL"
|
||||
(->> [4] (concat [3]) (concat [2]) rest (concat [1]))
|
||||
;=>(1 3 4)
|
||||
|
||||
@ -286,12 +286,15 @@
|
||||
(let* [or_FIXME 23] (or false (+ or_FIXME 100)))
|
||||
;=>123
|
||||
|
||||
;; Loading sumdown from computations.mal
|
||||
(load-file "../tests/computations.mal")
|
||||
|
||||
;;
|
||||
;; Testing time-ms function
|
||||
(def! start-time (time-ms))
|
||||
(= start-time 0)
|
||||
;=>false
|
||||
(let* [sumdown (fn* (N) (if (> N 0) (+ N (sumdown (- N 1))) 0))] (sumdown 10)) ; Waste some time
|
||||
(sumdown 10) ; Waste some time
|
||||
;=>55
|
||||
(> (time-ms) start-time)
|
||||
;=>true
|
||||
|
||||
Loading…
Reference in New Issue
Block a user