yorick: Fix evaluation of empty vectors in steps 2 and 3

[jackhill/mal.git] / examples / exercises.mal

;; These are the answers to the questions in ../docs/exercise.md.

;; In order to avoid unexpected circular dependencies among solutions,
;; this files attempts to be self-contained.
(def! identity (fn* [x] x))
(def! reduce (fn* (f init xs)
  (if (empty? xs) init (reduce f (f init (first xs)) (rest xs)))))
(def! foldr (fn* [f init xs]
  (if (empty? xs) init (f (first xs) (foldr f init (rest xs))))))

;; Reimplementations.

(def! nil?   (fn* [x] (= x nil  )))
(def! true?  (fn* [x] (= x true )))
(def! false? (fn* [x] (= x false)))
(def! empty? (fn* [x] (= x []   )))

(def! sequential?
  (fn* [x]
    (if (list? x) true (vector? x))))

(def! >  (fn* [a b]      (< b a) ))
(def! <= (fn* [a b] (not (< b a))))
(def! >= (fn* [a b] (not (< a b))))

(def! hash-map (fn* [& xs] (apply assoc {} xs)))
(def! list (fn* [& xs] xs))
(def! prn (fn* [& xs] (println (apply pr-str xs))))
(def! swap! (fn* [a f & xs] (reset! a (apply f (deref a) xs))))

(def! count
  (fn* [xs]
    (if (nil? xs)
      0
      (reduce (fn* [acc _] (+ 1 acc)) 0 xs))))
(def! nth
  (fn* [xs index]
    (if (if (<= 0 index) (not (empty? xs))) ; logical and
      (if (= 0 index)
        (first xs)
        (nth (rest xs) (- index 1)))
      (throw "nth: index out of range"))))
(def! map
  (fn* [f xs]
    (foldr (fn* [x acc] (cons (f x) acc)) () xs)))
(def! concat
   (fn* [& xs]
    (foldr (fn* [xs ys] (foldr cons ys xs)) () xs)))
(def! conj
  (fn* [xs & ys]
    (if (vector? xs)
      (apply vector (concat xs ys))
      (reduce (fn* [xs x] (cons x xs)) xs ys))))

(def! do2 (fn* [& xs] (nth xs (- (count xs) 1))))
(def! do3 (fn* [& xs] (reduce (fn* [acc x] x) nil xs)))
;; do2 will probably be more efficient when lists are implemented as
;; arrays with direct indexing, but when they are implemented as
;; linked lists, do3 may win because it only does one traversal.

(defmacro! quote (fn* [ast] (list (fn* [] ast))))
(def! _quasiquote_iter (fn* [x acc]
  (if (if (list? x) (= (first x) 'splice-unquote)) ; logical and
    (list 'concat (first (rest x)) acc)
    (list 'cons (list 'quasiquote x) acc))))
(defmacro! quasiquote (fn* [ast]
  (if (list? ast)
    (if (= (first ast) 'unquote)
      (first (rest ast))
      (foldr _quasiquote_iter () ast))
    (if (vector? ast)
      ;; TODO: once tests are fixed, replace 'list with 'vector.
      (list 'apply 'list (foldr _quasiquote_iter () ast))
      (list 'quote ast)))))

(def! _letA_keys (fn* [binds]
  (if (empty? binds)
    ()
    (cons (first binds) (_letA_keys (rest (rest binds)))))))
(def! _letA_values (fn* [binds]
  (if (empty? binds)
    ()
    (_letA_keys (rest binds)))))
(def! _letA (fn* [binds form]
  (cons (list 'fn* (_letA_keys binds) form) (_letA_values binds))))
;; Fails for (let* [a 1 b (+ 1 a)] b)
(def! _letB (fn* [binds form]
  (if (empty? binds)
    form
    (list (list 'fn* [(first binds)] (_letB (rest (rest binds)) form))
          (first (rest binds))))))
;; Fails for (let* (cst (fn* (n) (if (= n 0) nil (cst (- n 1))))) (cst 1))
(def! _c_combinator (fn* [x] (x x)))
(def! _d_combinator (fn* [f] (fn* [x] (f (fn* [v] ((x x) v))))))
(def! _Y_combinator (fn* [x] (_c_combinator (_d_combinator x))))
(def! _letC
  (fn* [binds form]
    (if (empty? binds)
      form
      (list (list 'fn* [(first binds)] (_letC (rest (rest binds)) form))
            (list '_Y_combinator (list 'fn* [(first binds)] (first (rest binds))))))))
;; Fails for mutual recursion.
;; See http://okmij.org/ftp/Computation/fixed-point-combinators.html
;; if you are motivated to implement solution D.
(defmacro! let* _letC)

(def! apply
  ;; Replace (f a b [c d]) with ('f 'a 'b 'c 'd) then evaluate the
  ;; resulting function call (the surrounding environment does not
  ;; matter when evaluating a function call).
  ;; Use nil as marker to detect deepest recursive call.
  (let* [q    (fn* [x] (list 'quote x))
         iter (fn* [x acc]
                (if (nil? acc) ; x is the last element (a sequence)
                  (map q x)
                  (cons (q x) acc)))]
    (fn* [& xs] (eval (foldr iter nil xs)))))

;; Folds

(def! sum     (fn* [xs] (reduce + 0 xs)))
(def! product (fn* [xs] (reduce * 1 xs)))

(def! conjunction
  (let* [and2 (fn* [acc x] (if acc x false))]
    (fn* [xs]
      (reduce and2 true xs))))
(def! disjunction
  (let* [or2 (fn* [acc x] (if acc true x))]
    (fn* [xs]
      (reduce or2 false xs))))
;; It would be faster to stop the iteration on first failure
;; (conjunction) or success (disjunction). Even better, `or` in the
;; stepA and `and` in `core.mal` stop evaluating their arguments.

;; Yes, -2-3-4 means (((0-2)-3)-4).

;; `(reduce str "" xs)` is equivalent to `apply str xs`
;; and `(reduce concat () xs)` is equivalent to `apply concat xs`.
;; The built-in iterations are probably faster.

;; `(reduce (fn* [acc _] acc) nil xs)` is equivalent to `nil`.

;; For (reduce (fn* [acc x] x) nil xs))), see do3 above.

;; `(reduce (fn* [acc x] (if (< acc x) x acc)) 0 xs)` computes the
;; maximum of a list of non-negative integers. It is hard to find an
;; initial value fitting all purposes.

(def! sum_len
  (let* [add_len (fn* [acc x] (+ acc (count x)))]
    (fn* [xs]
      (reduce add_len 0 xs))))
(def! max_len
  (let* [update_max (fn* [acc x] (let* [l (count x)] (if (< acc l) l acc)))]
    (fn* [xs]
      (reduce update_max 0 xs))))

(def! compose
  (let* [compose2 (fn* [f acc] (fn* [x] (f (acc x))))]
    (fn* [& fs]
      (foldr compose2 identity fs))))
;; ((compose f1 f2) x) is equivalent to (f1 (f2 x))
;; This is the mathematical composition. For practical purposes, `->`
;; and `->>` defined in `core.mal` are more efficient and general.