Last active
March 29, 2018 12:10
-
-
Save jkxyz/714bfb6b28264d93f2481c85e7fbbf64 to your computer and use it in GitHub Desktop.
Forth in Clojure, so far
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(ns forth.core | |
"Forth in Clojure" | |
(:require [clojure.test :refer [deftest is are]])) | |
(defn npop | |
"Returns a list without the first n items by applying pop repeatedly." | |
[n coll] | |
((apply comp (repeat n pop)) coll)) | |
(defn ffn | |
"Returns a fn which takes n items from the input stack, applies them to f, | |
and pushes o items (from the result of f) back onto the stack." | |
[n o f] | |
#(apply conj (npop n %) (take o (apply f (take n %))))) | |
(defn fapply | |
"For an int or fn f, applies it to the stack s." | |
[s f] | |
(if (integer? f) (conj s f) (f s))) | |
(defn feval | |
"For a list of ints or fns fs, applies them to the stack s." | |
[s & fs] | |
(reduce fapply s fs)) | |
(defn f | |
"Returns a fn which applies the int i to the input stack." | |
[i] | |
#(fapply % i)) | |
;; Forth Words | |
(def f+ (ffn 2 1 (comp list +))) ; ( n1 n2 -- sum ) | |
(def f- (ffn 2 1 (comp list -))) ; ( n1 n2 -- difference ) | |
(def f* (ffn 2 1 (comp list *))) ; ( n1 n2 -- product ) | |
(def fdiv (ffn 2 1 #(list (int (/ %2 %1))))) ; ( n1 n2 -- quotient ) | |
(def fdup (ffn 1 2 #(repeat 2 %))) ; ( n -- n n ) | |
(def fsquare (comp f* fdup)) ; ( n -- square ) | |
(def fp (ffn 1 0 print)) ; ( n -- ) | |
(def fswap (ffn 2 2 list)) ; ( n1 n2 -- n2 n1 ) | |
(def fdrop (ffn 1 0 identity)) ; ( n -- ) | |
(def fover (ffn 2 3 #(list %2 %1 %2))) ; ( n1 n2 -- n1 n2 n1 ) | |
(def femit (ffn 1 0 (comp print char))) ; ( n -- ) | |
(def fcr (comp femit (f 10))) ; ( -- ) | |
(deftest arithmetic | |
(are [x y] (= x (first y)) | |
(+ 7 8) (feval '() 8 7 f+) | |
(- 8 7) (feval '() 7 8 f-) | |
(* 5 6) (feval '() 5 6 f*) | |
(/ 6 3) (feval '() 6 3 fdiv) | |
0 (feval '() 3 6 fdiv) | |
(* 5 5) (feval '() 5 fsquare))) | |
(deftest stack-operations | |
(is (= '(1 2 3) (feval '() 3 1 2 fswap))) | |
(is (= '(2 3) (feval '() 3 2 1 fdrop))) | |
(is (= '(1 2 1) (feval '() 1 2 fover)))) | |
(def stack (atom (list))) | |
(defn feval! [& fs] (swap! stack #(apply feval % fs))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment