Ferret Programmer's Manual

(configure-ferret! :command "~/apps/arduino-1.8.0/arduino \\
                               --board arduino:sam:arduino_due_x_dbg \\
                               --port /dev/ttyACM0 \\
                               --upload ./blink.cpp")

FERRET  = ferret
INPUT   = core.clj
OUTPUT  = core.ino
ARDUINO = ~/arduino-1.8.5/arduino
BOARD   = arduino:sam:arduino_due_x_dbg
PORT    = /dev/ttyACM0
RM      = rm -f

.PHONY: verify upload clean

default: verify

core: core.clj
        $(FERRET) -o $(OUTPUT)

verify: core
        $(ARDUINO) --board $(BOARD) --verify $(OUTPUT)

upload: core
        $(ARDUINO) --board $(BOARD) --port $(PORT) --upload $(OUTPUT)

clean:
        $(RM) $(OUTPUT)

(configure-ferret! :command "mv blink.cpp blink.ino")

;; core.clj
(println "Hello World!")

# core_0.1.bb
SUMMARY = "Simple Ferret application"
SECTION = "examples"
LICENSE = "MIT"
LIC_FILES_CHKSUM = "file://${COMMON_LICENSE_DIR}/MIT;md5=0835ade698e0bcf8506ecda2f7b4f302"

SRC_URI = "file://core.cpp"

S = "${WORKDIR}"

do_compile() {
         ferret -i ./core.clj
         ${CXX} -std=c++11 core.cpp -o core
}

do_install() {
         install -d ${D}${bindir}
         install -m 0755 core ${D}${bindir}
}

(require 'package.io)

(require '[package.io :as io])

(require '[package.io :as io]
         '[package.udp :as udp])

(def ^{:private true}  helper-var :value)

(defn ^{:private true} helper-fn [] 42)

;;deps.clj
(git :url    "https://github.com/nakkaya/ferret-opencv.git")

(git :url    "https://github.com/nakkaya/ferret-mosquitto.git"
     :commit "8c8c0890194a0b98130a3d4d78b71c99b833b12a")

(defn checkout-deps [path]
  (when (io/file-exists (str path "/deps.clj"))
    (let [deps (-> (read-clojure-file "deps.clj")
                   (parser/peek (parser/form? 'git)))
          deps (map (fn [[_ & kvs]] (apply hash-map kvs)) deps)]
      (doseq [{url :url commit :commit} deps]
        (let [folder (str path (jgit-util/name-from-uri url))]
          (info "dep =>" url)
          (when (io/file-exists folder)
            (org.apache.commons.io.FileUtils/deleteDirectory
             (java.io.File. folder)))
          (let [repo (jgit/git-clone-full
                      url (org.apache.commons.io.FilenameUtils/normalize folder))]
            (jgit/git-checkout (:repo repo)
                               (if commit
                                 commit
                                 "master"))))))))

(defn import-modules-select-require [form]
  (let [norm-require (fn [f]
                       (if (symbol? f)
                         [f :as f]
                         f))]
    (->> (parser/peek form (parser/form? 'require))
         (reduce (fn[h v]
                   (if (= 2 (count v))
                     ;; require single module
                     (conj h (norm-require (->> v last last)))
                     ;; require multiple modules
                     (concat h (map #(norm-require (last %)) (rest v))))) [])
         (map (fn [[mod _ as]] [mod as]))
         (reduce (fn[h [mod as]]
                   (if (h mod)
                     (assoc h mod (conj (h mod) as))
                     (assoc h mod [as]))) {}))))

(defn import-modules-load-modules [package-list options]
  (->> package-list
       (reduce (fn[h [m aliases]]
                 (let [file-name      (str (.replace (str m) "." "/") ".clj")
                       mod            (-> (if (clojure.java.io/resource file-name)
                                            file-name
                                            (str (:path options) file-name))
                                          (read-clojure-file)
                                          (parser/drop (parser/form? 'configure-runtime!))
                                          (parser/drop (parser/form? 'configure-ferret!)))
                       macro-symbols  (->> (parser/peek mod (parser/form? 'defmacro))
                                           (map second)
                                           (into #{}))
                       def-symbols    (->> (parser/peek (expand-macros mod) (parser/form? 'def))
                                           (map second)
                                           (into #{}))
                       replace?       (set/union macro-symbols def-symbols)
                       mod            (parser/transform
                                       mod
                                       #(and (symbol? %)
                                             (replace? %))
                                       #(parser/new-symbol m "_" %))]
                   (reduce (fn [h v] (conj h v)) h mod)))
               [])
       lazy-seq))

(defn import-modules-convert-alias-to-module [package-list form]
  (let [alias-to-mod (reduce (fn[h [mod aliases]]
                               (reduce (fn[h v] (assoc h v mod)) h aliases))
                             {} package-list)]
    (parser/transform form symbol?
                      (fn [f]
                        (if-let [[_ alias fn] (re-find #"(.*?)/(.*)" (str f))]
                          (if-let [mod-sym (alias-to-mod (symbol alias))]
                            (parser/new-symbol mod-sym "_" fn)
                            f)
                          f)))))

(defn import-modules [form options]
  (let [package-list (import-modules-select-require form)
        form         (parser/drop form (parser/form? 'require))
        modules      (import-modules-load-modules package-list options)
        non-public?  (->> modules
                          (reduce (fn[private-symbols mod]
                                    (-> mod
                                        (parser/peek #(and (symbol? %)
                                                           (-> % meta :private)))
                                        (concat private-symbols))) [])
                          (into #{}))
        form         (import-modules-convert-alias-to-module package-list form)
        violations   (parser/peek form #(non-public? %) #(zip/node (zip/up %)))]
    (when (not (empty? violations))
      (doseq [v violations]
        (warn "non-public-access =>" v))
      (io/exit-failure))
    (shake-concat modules form)))

(defn import-modules-all [form options]
  (loop [f form]
    (let [expanded (import-modules f options)]
      (if (= f expanded)
        expanded
        (recur expanded)))))

(defn ferret-runtime [options form]
  (->> (-> form
           (import-modules-all options)
           (expand-reader-macros))
       (shake-concat (read-clojure-file "ferret/core.clj"))
       ;; tag form with the build info
       (cons `(~'native-define ~(try
                                  (let [version (io/read-file-from-url "build.info")]
                                    (str "// ferret-lisp " version))
                                  (catch Exception e
                                    (str "// ferret-lisp")))))))

(defn expand-reader-macros [form]
  (-> form
      (parser/transform
       (parser/form? 'clojure.core/deref)
       (fn [f] (cons 'deref (rest f))))
      (parser/transform
       map?
       (fn [x]
         (->> (seq x)
              (reduce
               (fn[h [k v]]
                 (conj h k v)) [])
              (seq)
              (cons 'fir-new-map))))))

(defn macro-normalize [f]
  (parser/transform f
                    (parser/form? 'let)
                    (fn [[_ bindings & body]]
                      `(~'let* ~(apply list bindings) ~@body))))

(defn expand-macros-single [form]
  (let [core-macros (->> (read-clojure-file "ferret/core.clj")
                         (filter (parser/form? 'defmacro)))
        core-macro-symbols (into #{} (map second core-macros))
        form-macros (->> (filter (parser/form? 'defmacro) form)
                         (filter (fn [[_ name]]
                                   (not (core-macro-symbols name)))))
        form-macro-symbols (map second form-macros)
        form (parser/drop form (parser/form? 'defmacro))
        temp-ns (gensym)
        macro-symbols (concat core-macro-symbols form-macro-symbols)]

    (create-ns temp-ns)
    (binding [*ns* (the-ns temp-ns)]
      (refer 'clojure.core :exclude (concat macro-symbols ['fn 'def]))
      (use '[compiler.io :only [exit-failure]])
      (use '[compiler.core :only [symbol-conversion]])
      (use '[compiler.parser :only [new-fir-fn]])

      (doseq [m (concat core-macros form-macros)]
        (eval m)))

    (let [form (-> form
                   (macro-normalize)
                   (expand-reader-macros)
                   (parser/transform
                    (fn [f]
                      (some true? (map #(parser/form? % f) macro-symbols)))
                    (fn [f]
                      (binding [*ns* (the-ns temp-ns)]
                        (-> (walk/macroexpand-all f)
                            ;;strip ns from symbols
                            (parser/transform symbol? #(-> % name symbol)))))))]
      (remove-ns temp-ns)
      form)))

(defn expand-macros-aux [form]
  (loop [f form]
    (let [expanded (expand-macros-single f)]
      (if (= f expanded)
        expanded
        (recur expanded)))))

(def expand-macros (memoize expand-macros-aux))

(let->fn '(let* [a 1
                 b 2]
            (+ a b)))

((fn* [a__1548] ((fn* [b__1549] (+ a__1548 b__1549)) 2)) 1)

(deftest let-test
  (let [args (list "1" "2")]
    (is (= args (rest *command-line-args*))))

  (let [a 1]
    (is (= 1 a)))

  (let [a 1
        a 3]
    (is (= 3 a)))

  (let [a 1
        b 2]
    (is (= 3 (+ a b))))

  (let [a 1
        b 2
        c 3]
    (is (= 6 (+ a b c))))

  (let [a 1
        b 2]
    (let []
      (is (= 3 (+ a b)))))

  (let [x 42]
    (defn let-over-lambda [] x))

  (is (= 42 (let-over-lambda))))

(defn let-closure [bindings body]
  (if (empty? bindings)
    `((~'fir-let-fn () ~@body))
    (apply
     (fn close [[arg val] & more]
       (if (empty? more)
         `((~'fir-let-fn [~arg] ~@body) ~val)
         `((~'fir-let-fn [~arg] ~(apply close more)) ~val)))
     (partition 2 bindings))))

(defn let-assert [bindings body]
  (when (odd? (count bindings))
    (warn
     (str "let requires an even number of forms in binding vector => " bindings))
    (io/exit-failure)))

(defn let->fn [form]
  (-> form

      (parser/transform (parser/form? 'let*)
                        (fn [[_ bindings & body]]
                          (let-assert bindings body)
                          (let-closure bindings body)))

      (parser/transform (parser/form? 'fir-let-fn)
                        (fn [[_ args & body]]
                          (parser/new-fir-fn :args args :body body)))))

(do->fn '(do (+ 1 1)))

((fn [] (+ 1 1)))

(defn do->fn [form]
  (parser/transform form
                    (parser/form? 'do)
                    (fn [f] `(~(parser/new-fir-fn :body (rest f))))))

(defn make-adder [x]
  (fn [n] (+ x n)))

(def adder
  (make-adder 1))

(def fibo
  (fn [n]
    (if (< n 2)
      1
      (+ (fibo (- n 1))
         (fibo (- n 2))))))

(deftest fn->list-test
  (is (= 10 (adder 9)))
  (is (= 89 (fibo 10))))

(fn->lift '(fn* [x]
                (fn* [n] (+ x n))))

(fir-defn-heap G__1333  (x) (n)  (+ x n))
(fir-defn-heap G__1334  ()  (x)  (fir-fn-heap G__1333 x))
(fir-fn-heap G__1334)

(defn fn-defined? [fns env args body]
  (if-let [fn-name (@fns (concat [env args] body))]
    (apply list 'fir-fn-heap fn-name env)))

(defn define-fn [fns env name args body]
  (let [n (if name
            name
            (gensym "FN__"))]
    (swap! fns assoc (concat [env args] body) n)
    (apply list 'fir-fn-heap n env)))

(defn fn->lift
  ([form]
   (let [fns  (atom (ordered-map/ordered-map))
         form (fn->lift form fns)
         fns  (map (fn [[body name]] (concat ['fir-defn-heap name] body)) @fns)]
     (concat fns form)))
  ([form fns & [env]]
   (parser/transform
    form
    (parser/form? 'fn*)
    (fn [sig]
      (let [[name args body] (parser/split-fn sig)
            ;; transform named recursion in body
            body (if name
                   (parser/transform
                    body
                    (parser/form? name)
                    (fn [[_ & args]]
                      (cons
                       (apply list 'fir-fn-heap name env)
                       args)))
                   body)
            body (fn->lift body fns (concat args env))
            symbols (parser/symbol-set body)
            env  (->> (set/intersection
                       symbols
                       (into #{} (flatten env)))
                      (into ()))

            args (if (parser/ffi-fn?
                      (filter #(not (parser/form? 'native-declare %)) body))
                   args
                   (parser/transform args
                                     symbol?
                                     (fn [v]
                                       (if (or (not (parser/fn-arg-symbol? v))
                                               (symbols v))
                                         v '_))))]
        (if-let [n (fn-defined? fns env args body)]
          n
          (define-fn fns env name args body)))))))

(deftest test-fn->lift
  (let [prg-a (compile '((defn one-plus-one []
                           (+ 1 1))

                         (while true
                           (+ 1 1))) {})
        prg-b (fn->lift
               '(fn* outer [a]
                     (fn* inner-a [b]
                          (+ a b))
                     (fn* inner-b [c] c)))

        prg-c (fn->lift
               '((fn* inner-a [a]
                      ((fn* inner-b [b]
                            ((fn* inner-c [c] (+ b c))
                             3))
                       2))
                 1))
        prg-d (fn->lift
               '((fn* inner-a [a]
                      ((fn* inner-b [b]
                            ((fn* inner-c [c] (+ b))
                             3))
                       2))
                 1))]
    ;;while shoud use one-plus-one in its body
    ;;check fn-defined?
    (is (= 2 (count (parser/peek prg-a (fn [f] (= 'one_plus_one f))))))

    (is (= 1 (->> (fn [f] (= '(fir-defn-heap inner-a (a) [b] (+ a b)) f))
                  (parser/peek prg-b)
                  count)))
    (is (= 1 (->> (fn [f] (= '(fir-defn-heap inner-b () [c] c) f))
                  (parser/peek prg-b)
                  count)))
    (is (= 1 (->> (fn [f] (= '(fir-defn-heap inner-c (b) [c] (+ b c)) f))
                  (parser/peek prg-c)
                  count)))
    (is (= 1 (->> (fn [f] (= '(fir-defn-heap inner-c (b) [_] (+ b)) f))
                  (parser/peek prg-d)
                  count)))))

(defn escape-cpp-symbol [s]
  (clojure.string/escape
   (str s)
   {\- \_ \* "_star_" \+ "_plus_" \/ "_slash_"
    \< "_lt_" \> "_gt_" \= "_eq_" \? "_QMARK_"
    \! "_BANG_" \# "_"}))

(defn symbol-conversion [form]
  (let [c (comp #(symbol (escape-cpp-symbol %))
                #(cond (= 'not %) '_not_
                       :default %))]
    (parser/transform form symbol? c)))

(defn remove-assertions [options form]
  (if (:release options)
    (do (info "option => release mode")
        (parser/drop form (parser/form? 'assert)))
    form))

(defn read-clojure-file [f]
  (let [ns (gensym)
        ns-str (str ns)]
    (create-ns ns)
    (binding [*ns* (the-ns ns)]
      (refer 'clojure.core)
      (-> (read-string (str \( (io/read-file f) \)))
          (parser/transform
           symbol?
           #(if (= (namespace %) ns-str)
              (-> % name symbol)
              %))
          ;;replace clojure.core/fn with fn
          ;;replace clojure.core/while with while
          (parser/transform
           (fn [x]
             (and (parser/form? 'quote x)
                  (or (= 'clojure.core/fn    (second x))
                      (= 'clojure.core/defn  (second x))
                      (= 'clojure.core/while (second x)))))
           (fn [[_ s]] `'~(-> s name symbol)))))))

(form? 'fn* '(fn* [n] (+ x n)))
;; true

(defn form?
  ([s]
   #(form? s %))
  ([s f]
   (and (seq? f)
        (= (first f) s))))

(defn symbol-set [form]
  (->> form flatten (filter symbol?) (into #{})))

(defn split-fn [sig]
  (let [name (if (symbol? (second sig)) (second sig) nil)
        sig  (if name (clojure.core/drop 2 sig) (rest sig))
        [args & body] sig]
    [name args body]))

(defn ffi-fn? [body]
  (and (not (nil? body))
       (not (empty? body))
       (->> (map string? body)
            (every? true?))))

(defn fn-arg-symbol? [s]
  (and (symbol? s)
       (not= s '&)
       (not= s '_)
       (not= s 'fir-destructure-associative)))

(defn transform [tree pred f]
  (walk/prewalk (fn [form]
                  (if (pred form)
                    (let [new-form (f form)
                          meta (meta form)]
                      (if (and (instance? clojure.lang.IMeta form)
                               (instance? clojure.lang.IMeta new-form))
                        (with-meta new-form meta)
                        new-form))
                    form))
                tree))

(defn drop [tree pred]
  (if (every? true? (map #(pred %) tree))
    (list )
    (loop [loc (zip/seq-zip tree)]
      (if (zip/end? loc)
        (zip/root loc)
        (recur
         (zip/next
          (if (pred (zip/node loc))
            (zip/remove loc)
            loc)))))))

(defn peek [tree pred & [node-fn]]
  (let [node-fn (if node-fn
                  node-fn
                  #(zip/node %))]
    (loop [loc (zip/seq-zip tree)
           nodes []]
      (if (zip/end? loc)
        nodes
        (recur
         (zip/next loc)
         (if (pred (zip/node loc))
           (conj nodes (node-fn loc))
           nodes))))))

(fn [a b] (list a b))
;;becomes
(fn [a__1510 b__1511] (list a__1510 b__1511))

(defn new-symbol [& parts]
  (let [parts (map #(.replace (str %) "." "_") parts)]
    (symbol (apply str parts))))

(defn fn-make-unique [args body]
  (if (string?  (->> body
                     (filter #(not (form? 'native-declare %)))
                     first))
    [args body]
    (let [unique-args (->> args
                           flatten
                           (filter fn-arg-symbol?)
                           (map #(new-symbol % (gensym "__"))))
          replace? (->> (interleave (->> args
                                         flatten
                                         (filter fn-arg-symbol?))
                                    unique-args)
                        (apply hash-map))
          body      (transform body #(replace? %) #(replace? %))
          replace?  (merge replace? {'fir-new-map 'fir-destructure-associative})
          args      (transform args #(replace? %) #(replace? %))]
      [args body])))

(defn new-fir-fn
  ([& {:keys [name args body escape] :or {escape  true
                                          args    []}}]
   (let [name-unique (if name
                       (new-symbol name (gensym "__")))
         [args body] (if escape
                       (fn-make-unique args body)
                       [args body])
         body        (if name-unique
                       (transform body #(= % name) (fn [_] name-unique))
                       body)]
     (if name-unique
       `(fn* ~name-unique ~args ~@body)
       `(fn* ~args ~@body)))))

(defmethod emit :symbol [_ form state] (str form))

(defmethod emit :string [_ form state]
  (str "obj<string>(\"" (io/escape-string form) "\"," (count form) ")"))

(defmethod emit :boolean [_ form state]
  (if (true? form)
    (str "cached::true_o")
    (str "cached::false_o")))

(defmethod emit :nil [_ form state] "nil()")

(defmethod emit :keyword [_ form _]
  (str "obj<keyword>(" (reduce (fn[h v] (+ h (int v))) 0 (str form)) ")"))

(defmethod emit :char [_ form state] (str "obj<number>(" (int form) ")"))

(defmethod emit :number [_ form state] (str "obj<number>(" (double form) ")"))

(defmethod emit 'fir_new_map [options [_ & kvs] state]
  (let [kvs (partition 2 kvs)
        keys (->> (map first kvs)
                  (map #(emit options % state))
                  (interpose \,))
        vals (->> (map second kvs)
                  (map #(emit options % state))
                  (interpose \,))]
    (str "obj<map_t>("
         "rt::list(" (apply str keys) "),"
         "rt::list(" (apply str vals) "))")))

(defmethod emit :regex-pattern [options regex state]
  (emit options
        (org.apache.commons.lang.StringEscapeUtils/unescapeJava
         (str regex))
        state))

(defmethod emit 'def [options [_ name & form] state]
  (append-to! state [:symbol-table] name)
  (str "(" name " = " (apply str (emit-ast options form state)) ")"))

(defmethod emit 'if [options [_ cond t f] state]
  (let [cond (emit options cond state)
        t (emit options t state)
        f (if (nil? f) "nil()" (emit options f state))]
    (apply str "(" cond " ? " t " : " f ")")))

(defn defobject [name f options]
  (let [def (io/read-file (first f) options)]
    (render-template
     "#ifndef FERRET_OBJECT_$guard$
      #define FERRET_OBJECT_$guard$
       $body$
      #endif"
     :guard       (.toUpperCase (str name))
     :body        def)))

(defmethod emit 'list [options [fn & args] state]
  (let [elements  (->> (emit-ast options args state)
                       (interpose \,)
                       (apply str))]
    (str "rt::list(" elements ")")))

(defmethod emit 'defobject [options [_ name & spec] state]
  (append-to! state [:objects] (defobject name spec options)))

(defmethod emit 'matrix [options [_ elements] state]
  (let [rows (count elements)
        cols (-> elements first count)
        elements (apply concat elements)
        elements (map #(if (number? %)
                         (str "real_t(" % ")")
                         (str
                          "number::to<real_t>"
                          "(" (emit options % state) ")"))
                      elements)
        elements (apply str (interpose \, elements))
        matrix-t (str "size_t(" rows "), size_t(" cols ")," elements)
        matrix-decl (str "obj<matrix_t>(" matrix-t ")")]
    matrix-decl))

(defmethod emit 'native_header [_ [_ & declarations] state]
  (append-to! state [:native-headers] declarations))

(defmethod emit 'native_declare [_ [_ declaration] state]
  (append-to! state [:native-declarations] declaration))

(defmethod emit 'native_define [_ [_ define] state]
  (append-to! state [:native-defines] define))

(defmethod emit 'fir_inline_list [options [_ & args] state]
  (str "rt::list(" (apply str (interpose \, (emit-ast options args state))) ")"))

(defmethod emit 'fir_inline_first [options [_ & seq] state]
  (str "rt::first(" (apply str (emit-ast options seq state)) ")"))

(defmethod emit 'fir_inline_rest [options [_ & seq] state]
  (str "rt::rest(" (apply str (emit-ast options seq state)) ")"))

(defn norm-fn-env [env]
  (->> env
       (flatten)
       (filter #(and (not (= '& %))
                     (not (= '_ %))
                     (not (= :as %))))))

(defn new-fn-heap [l]
  (let [n (second l)
        e (norm-fn-env (drop 2 l))]
    (if (empty? e)
      (str "obj<" n ">()")
      (str "obj<" n ">(" (apply str (interpose \, e)) ")"))))

(defn new-fn-stack [l]
  (let [n (second l)
        e (norm-fn-env (drop 2 l))]
    (if (empty? e)
      (str n "()")
      (str n "(" (apply str (interpose \, e)) ")"))))

(defn invoke-fn [n args]
  (if (empty? args)
    (str "run(" n ")")
    (str "run(" n ","  (apply str (interpose \, args))")")))

(defn destructure-test-1 [[a b c]]
  (list a b c))

(defn destructure-test-2 [[a [b] c]]
  b)

(defn destructure-test-3 [[a [_ b] c]]
  b)

(defn destructure-test-4 [& a]
  a)

(defn destructure-test-5 []
  (let [[a b c] (list 1 2 3)]
    (list a b c)))

(defn destructure-test-6 []
  (let [[_ _ a] (list 1 2 3)]
    a))

(defn destructure-test-7 [a b & [c d]]
  (list c d))

(defn destructure-test-8 [{a :a} b {c :c}]
  (list a b c))

(deftest destructuring-test
  (is (= 3                   (count (destructure-test-1 (list 1 2 3)))))
  (is (= 2                   (destructure-test-2 (list 1 (list 2) 3))))
  (is (= 3                   (destructure-test-3 (list 1 (list 2 3) 3))))
  (is (= (list (list 1 2 3)) (destructure-test-4 (list 1 2 3))))
  (is (= (list 1 2 3)        (destructure-test-8 {:a 1} 2 {:c 3})))

  (let [a (list 1 2 3 4)
        [b c & r] a]

    (is (= 1          b))
    (is (= 2          c))
    (is (= (list 3 4) r)))

  (let [a 1 b 2
        [c & r] (list 4 5)]

    (is (= 1 a))
    (is (= 2 b))
    (is (= 4 c))
    (is (= (list 5) r)))

  (let [[a & r] (list 1 2 3)
        rr (rest r)]
    (is (= (list 3) rr)))

  (is (= (list 1 2 3) (destructure-test-5)))
  (is (= 3            (destructure-test-6)))
  (is (= (list 3 4)   (destructure-test-7 1 2 3 4)))

  (let [[a & b :as all-list]   (list 1 2 3)
        [c     :as other-list] all-list]
    (is (= 1            a))
    (is (= (list 2 3)   b))
    (is (= (list 1 2 3) all-list))
    (is (= 1            c))
    (is (= (list 1 2 3) other-list)))

  (let [[_ _ a] (list 1 2 3)
        [_ b] (list 4 5 6)]
    (is (= 3 a))
    (is (= 5 b)))

  (let [a (list 1 2 3)
        [b c d e f g] a]
    (is (= 1   b))
    (is (= 2   c))
    (is (= 3   d))
    (is (= nil e))
    (is (= nil f))
    (is (= nil g))))

(declare destructure-arguments)

(defn destructure-nth-rest [parent pos]
  (reduce (fn[h v] (str v "(" h ")")) parent (repeat pos "rt::rest")))

(defn destructure-nth [parent pos]
  (str "rt::first(" (destructure-nth-rest parent pos) ")"))

(defn destructure-get [name parent key]
  (str "ref " name " = "
       parent ".cast<map_t>()->val_at(rt::list(" (emit nil key nil) "));"))

(defn new-fn-arg [name parent pos]
  (let [value (destructure-nth parent pos)
        tag   (-> name meta :tag)]
    (condp = tag
      'bool_t     (str "bool " name " = " "bool(" value ")")
      'real_t     (str "real_t " name " = " "number::to<real_t>(" value ")")
      'number_t   (str "number_t " name " = " "number::to<number_t>(" value ")")
      'size_t     (str "size_t " name " = " "number::to<size_t>(" value ")")
      'byte       (str "byte " name " = " "number::to<byte>(" value ")")
      'c_str      (str "var " name "_packed = string::pack(" value ");\n"
                       "char* " name " = " "string::c_str(" name "_packed)")
      'matrix     (str "matrix &" name " = " "value<matrix>::to_reference(" value ")")
      (str "ref " name " = " value))))

(defn new-fn-var-arg [name parent pos]
  (str "ref " name " = " (destructure-nth-rest parent pos)))

(defn destructure-associative [name parent pos]
  (let [tmp-name (gensym)]
    [(new-fn-arg tmp-name parent pos)
     (map (fn [[s k]] (destructure-get s tmp-name k)) name)]))

(defn destructure-sequential [args parent]
  (reduce
   (fn [h [pos name]]
     (let [name (cond
                  (symbol? name)
                  (new-fn-arg name parent pos)

                  (parser/form? 'fir_destructure_associative name)
                  (let [[_ & args ] name
                        args (->> args
                                  (partition 2)
                                  (remove #(= (first %) '_))
                                  flatten
                                  (apply hash-map))]
                    (destructure-associative args parent pos))

                  (coll?   name)
                  (destructure-arguments name (destructure-nth parent pos)))]
       (conj h name))) [] args))

(defn destructure-var-args [name parent pos]
  (cond (nil?     name)  []
        (symbol?  name)  (new-fn-var-arg name parent pos)
        (coll?    name)  (let [tmp-name (gensym)]
                           [(new-fn-var-arg tmp-name parent pos)
                            (destructure-arguments name tmp-name)])))

(defn destructure-as-arg [name parent]
  (if (symbol?     name)
    (new-fn-var-arg name parent 0)
    []))

(defn destructure-arguments
  ([args]
   (->> (destructure-arguments args "_args_") flatten))
  ([args parent]
   (let [t-args         args
         args           (take-while #(and (not= % '&) (not= % :as)) t-args)
         var-args       (->> t-args (drop-while #(not= % '&)) second)
         as-arg         (->> t-args (drop-while #(not= % :as)) second)
         args-indexed   (->>  args
                              (map-indexed (fn [p v] [p v]))
                              (filter #(not= (second %) '_)))
         as-arg         (destructure-as-arg as-arg parent)
         var-args       (destructure-var-args var-args parent (count args))
         args           (destructure-sequential args-indexed parent)]
     [args var-args as-arg])))

(defmethod emit :invoke-fn [options [fn & args] state]
  (invoke-fn (emit options fn state) (emit-ast options args state)))

(defmethod emit 'fir_fn_heap [_ f state]
  (new-fn-heap f))

(defmethod emit 'fir_fn_stack [_ f state]
  (new-fn-stack f))

(defn emit-lambda [options name env args body state]
  (let [native-declarations (filter (parser/form? 'native_declare) body)
        return (fn [b] (conj (pop b) (str "return " (last b))))
        body (filter #(not (parser/form? 'native_declare %)) body)
        body (cond  (empty? body)
                    ["return nil()"]
                    ;; multi arity dispacth
                    (parser/form? 'fir_defn_arity (first body))
                    (return
                     (emit options (first body) state))
                    ;; ffi call
                    (parser/ffi-fn? body)
                    (let [buffer (StringBuilder.)]
                      (doseq [b body]
                        (.append buffer b))
                      (let [body (.toString buffer)]
                        (cond (.contains body "__result")
                              ["var __result" body "return __result"]
                              (.contains body "return")
                              [body]
                              :default [body "return nil()"])))
                    ;; s-expression
                    :default (return
                              (emit-ast options body state)))
        env  (norm-fn-env env)
        vars (destructure-arguments args)]
    (doseq [dec native-declarations] 
      (emit options dec state))
    {:name name :env env :args args :vars vars :body body}))

(defmethod emit 'fir_defn_heap [options [_ name env args & body] state]
  (append-to! state [:lambdas] (emit-lambda options name env args body state)))

(defmethod emit 'fir_defn_stack [options [_ name env args & body] state]
  (append-to! state [:lambdas] (-> (emit-lambda options name env args body state)
                                   (assoc :stack true))))

(defmethod emit 'fir_defn_arity [_ [_ switch default] state]
  (let [default (if default
                  (str (new-fn-stack default) ".invoke(_args_)")
                  "nil()")
        switch  (render-template
                 "switch(rt::count(_args_)) {
                  $fns: {fn|
                    case $fn.case$ :
                       return $fn.fn$.invoke(_args_); };separator=\"\n\"$
                  }"
                 :fns (map (fn [[s f]] {:fn (new-fn-stack f) :case s}) switch))]
    [switch default]))

(defn lambda-definitions [fns]
  (render-template
   "$fns: {fn|
      $if(!fn.stack)$
       class $fn.name$ final : public lambda_i{
      $else$
       class $fn.name$  \\{
      $endif$
        $fn.env:{const var $it$;} ;separator=\"\n\"$
      public:
        $if(fn.env)$
          explicit $fn.name$ ($fn.env:{ref $it$} ;separator=\",\"$) :
            $fn.env:{$it$($it$)} ;separator=\",\"$ { }
        $endif$

        var invoke (ref _args_) const $if(!fn.stack)$ final $endif$ ;
      };};separator=\"\n\n\"$"
   :fns fns))

(defn lambda-implementations [fns]
  (render-template
   "$fns: {fn|
      inline var $fn.name$::invoke (ref _args_) const {
        (void)(_args_);
        $fn.vars:{$it$;} ;separator=\"\n\"$

        $fn.body:{$it$;} ;separator=\"\n\"$
      }
     };separator=\"\n\n\"$"
   :fns fns))

(defn program-template [source options]
  (let [{:keys [body lambdas symbol-table native-headers objects
                native-declarations native-defines]} source
        native-headers (->> native-headers flatten (into #{}))
        file-ns        (-> options :base-name escape-cpp-symbol)
        main           (render-template
                        (io/read-file "main.cpp")
                        :file       file-ns)]
    (render-template
     "
        $native_defines:{$it$} ;separator=\"\n\"$
        $native_headers:{#include \"$it$\"} ;separator=\"\n\"$

        #ifndef FERRET_RUNTIME_H
        #define FERRET_RUNTIME_H
         $ferret_h$
        #endif

        // Objects
        namespace ferret{
         $objects:{$it$} ;separator=\"\n\"$
        }

        // Symbols
        namespace $file${
         using namespace ferret;

         #if defined(ARDUINO)
           typedef ferret::boolean boolean;
         #endif

         $symbols:{var $it$;} ;separator=\"\n\"$
        }

        $native_declarations:{$it$} ;separator=\"\n\"$

        // Runtime Implementations
        #ifndef FERRET_RUNTIME_CPP
        #define FERRET_RUNTIME_CPP
         $ferret_cpp$
        #endif

        // Lambda Prototypes
        namespace $file${
          $lambda_classes:{$it$} ;separator=\"\n\"$
        }

        // Command Line Arguments
        #if defined(FERRET_STD_LIB) &&               \\
            !defined(FERRET_DISABLE_CLI_ARGS) &&     \\
            !defined(FERRET_DISABLE_STD_MAIN)
          ferret::var _star_command_line_args_star_;
        #endif

        // Lambda Implementations
        namespace $file${
          $lambda_bodies:{$it$} ;separator=\"\n\"$
        }

        // Program Run
        namespace $file${
         void main(){
          $body:{$it$;} ;separator=\"\n\"$ 
         }
        }

        $ferret_main$"
     :file                 file-ns
     :native_defines       native-defines
     :ferret_h             (io/read-file "runtime.h")
     :native_headers       native-headers
     :objects              objects
     :symbols              symbol-table
     :native_declarations  native-declarations
     :ferret_cpp           (io/read-file "runtime.cpp")
     :lambda_classes       (lambda-definitions lambdas)
     :lambda_bodies        (lambda-implementations lambdas)
     :body                 (filter #(not (empty? %)) body)
     :ferret_main          main)))

(defn compile-options [& [options]]
  (merge {:compiler "g++"
          :compiler-options ["-std=c++11"]
          :source-extension io/extension-cpp
          :base-name "solution"
          :binary-file "solution"}
         options))

(defn file-name [options]
  (str (:base-name options) "." (:source-extension options)))

(defn cpp-file-name [options]
  (str (:output-path options) (file-name options)))

(defn compile-options-parse-source [file]
  (try
    (let [program (slurp file)
          options (->> program
                       (re-seq #"(?s)build-conf-begin.*?//(.*?)// build-conf-end")
                       (map second)
                       (map #(.replaceAll % "//" ""))
                       (map #(.replaceAll % "\n" " "))
                       (map read-string))
          keys (->> options
                    (map #(keys %))
                    flatten
                    (into #{})
                    (into []))
          combine (fn [key]
                    (->> options
                         (reduce (fn[h v]
                                   (if (nil? (key v))
                                     h
                                     (apply merge (flatten [h (key v)])))) #{})
                         (into [])))]
      (compile-options
       (reduce (fn[h v]
                 (assoc h v (combine v))) {} keys)))
    (catch Exception e
      (compile-options {}))))

(defn build-specs [input args]
  (fn []
    (let [args             (fn [k]
                             (->> args :options k))
          output           (if (args :output)
                             (args :output)
                             input)
          output-path      (io/file-path output)
          output-extension (if (args :output) 
                             (io/file-extension (args :output))
                             io/extension-cpp)
          base-name        (io/file-base-name output)
          input-path       (io/file-path input)
          output-file      (io/make-file output-path base-name output-extension)
          binary-file      (if (args :binary) 
                             (args :binary)
                             base-name)
          default-options  (compile-options-parse-source output-file)]
      (-> default-options
          (assoc :input-file         input)
          (assoc :base-name          base-name)
          (assoc :path               input-path)
          (assoc :output-path        output-path)
          (assoc :source-extension   output-extension)
          (assoc :binary-file        binary-file)
          (assoc :ast                (args :ast))
          (assoc :compile-program    (args :compile))
          (assoc :release            (args :release))
          (assoc :format-code        (not (args :disable-formatting)))
          (assoc :global-functions   (args :global-functions))
          (assoc :extra-source-files
                 (cond (not (empty? (:arguments args)))
                       (:arguments args)
                       (not (empty? (:extra-source-files default-options)))
                       (:extra-source-files default-options)
                       :default []))))))

(defn compile->cpp [form options]
  (let [file-name (cpp-file-name options)
        source    (emit-source form options)
        program   (program-template source options)]
    (io/write-to-file file-name program)
    (info "compiled" "=>" file-name)
    true))

(defn cxx-compiler [options]
  (let [compiler    (if (System/getenv "CXX")
                      (System/getenv "CXX")
                      (:compiler options))
        env-options (if (System/getenv "CXXFLAGS")
                      (seq (.split (System/getenv "CXXFLAGS") " ")))
        options     (->> (:compiler-options options) (map str))]
    [compiler (concat options env-options)]))

(defn cxx-command [options]
  (if (:command options)
    (flatten ["/usr/bin/env" "sh" "-c" (:command options)])
    (let [[cxx cxx-options] (cxx-compiler options)
          source-files  (map #(let [extension (io/file-extension %)]
                                [(cond (= extension "c") ["-x" "c"]
                                       (= extension "c++") ["-x" "c++"]
                                       :default "")
                                 %])
                             (:extra-source-files options))]
      (flatten [cxx cxx-options source-files
                ["-x" "c++"] (file-name options)
                ["-o" (:binary-file options)]]))))

(defn compile->binary [options]
  (let [command (cxx-command options)]
    (info "building" "=>" (apply str (interpose " " command)))
    (let [build-dir (:output-path options)
          ret (try
                (with-sh-dir build-dir
                  (apply sh command))
                (catch Exception e
                  (warn (str "error executing C++ compiler."))
                  (warn (str "" (.getMessage e)))
                  (io/exit-failure)))]
      (if (not= 0 (:exit ret))
        (do (warn "build error")
            (warn (:err ret))
            (io/exit-failure)))
      true)))

(defn clang-format [options]
  (let [file (cpp-file-name options)
        source (try (with-sh-dir "./"
                      (sh "clang-format" "-style" "{Standard: Cpp11}" file))
                    (catch Exception e nil))]
    (if source
      (do (info "formatting code")
          (io/write-to-file file (:out source))))))

(defn build-solution [spec-fn]
  (let [{:keys [input-file compile-program format-code path]} (spec-fn)]
    (info "dir =>" path)
    (info "file =>" input-file)

    (compile->cpp (read-clojure-file input-file) (spec-fn))

    (when format-code
      (clang-format (spec-fn)))

    (when compile-program
      (compile->binary (spec-fn)))))

(def program-options
  [["-i" "--input FILE"         "Input File" :default "./core.clj"]
   ["-o" "--output FILE"        "Output C++ File"]
   ["-b" "--binary FILE"        "Output Binary File"]
   ["-c" "--compile"            "Compile to Binary"]
   [nil  "--deps"               "Checkout Input Dependencies"]
   ["-w" "--watch-input"        "Automatically Recompile Input File on Change"]
   [nil  "--release"            "Compile in Release Mode. Strip Debug Information"]
   [nil  "--disable-formatting" "Disables Output File Formatting Using clang-format"]
   [nil  "--global-functions"   "Disables inline-global-fns Optimization"]
   [nil  "--ast"                "Print Intermediate AST"]
   [nil  "--silent"             "Silent or quiet mode"]
   ["-h" "--help"               "Print Help"]])

(defn -main [& args]
  (try
    (let [args (parse-opts args program-options)
          {:keys [help input deps watch-input silent]} (:options args)]

      (when help
        (try
          (let [version (io/read-file "build.info")]
            (print "ferret-lisp" version))
          (catch Exception e
            (print "ferret-lisp")))
        (println )
        (println )
        (println (:summary args))
        (io/exit-success))

      (when silent
        (System/setProperty "org.slf4j.simpleLogger.defaultLogLevel" "warn"))

      (when (not (io/file-exists input))
        (warn "no input file")
        (io/exit-failure))

      (let [specs (build-specs input args)]

        (when deps
          (try
            (checkout-deps (:path (specs)))
            (catch Exception e
              (io/exit-failure)))
          (io/exit-success))

        (if (not watch-input)
          (build-solution specs)
          (do (watcher/watcher [input]
                               (watcher/rate 1000)
                               (watcher/on-change
                                (fn [_] (build-solution specs))))
              @(promise)))
        (shutdown-agents))
      (io/exit-success))
    (catch Exception e
      (stacktrace/print-stack-trace e 10))))

template<typename>
void type_id(){}

using type_id_t = void(*)();
typedef type_id_t type_t;

class var;
typedef var const & ref;
class seekable_i;

template <typename rc>
class object_i : public rc{
public:
  object_i() { }
  virtual ~object_i() { };

  virtual type_t type() const = 0;

#if !defined(FERRET_DISABLE_STD_OUT)
  virtual void stream_console() const {
    rt::print("var#");
    const void* addr = this;
    rt::print(addr);
  }
#endif

  virtual bool equals(ref) const;

  virtual seekable_i* cast_seekable_i() { return nullptr; }

  void* operator new(size_t, void* ptr){ return ptr; }
  void  operator delete(void * ptr){ FERRET_ALLOCATOR::free(ptr); }
};

typedef object_i<FERRET_RC_POLICY> object;

#if !defined(FERRET_POINTER_T)
  #define FERRET_POINTER_T memory::pointer<object>
#endif

typedef FERRET_POINTER_T pointer_t;

class var{
public:
  explicit inline var(object* o = nullptr) : obj(o) { inc_ref(); }
  inline var(ref o)   : obj(o.obj) { inc_ref(); }
  inline var(var&& o) : obj(o.detach()) { }

  ~var() { dec_ref(); }

  inline var& operator=(var&& other){
    if (this != &other){
      dec_ref();
      obj = other.detach();
    }
    return *this;
  }

  inline var& operator= (ref other){
    if (obj != other.obj){
      dec_ref();
      obj = other.obj;
      inc_ref();
    }
    return *this;
  }

  bool equals (ref) const;

  bool operator==(ref other) const { return equals(other); }

  bool operator!=(ref other) const { return !equals(other); }

  void* operator new(size_t, void* ptr){ return ptr; }

  operator bool() const;

#if !defined(FERRET_DISABLE_STD_OUT)
  void stream_console() const {
    if (obj != nullptr )
      obj->stream_console();
    else
      rt::print("nil");
  }
#endif

  inline object* get() const { return obj; }

  template<typename T>
  inline T* cast() const { return static_cast<T*>((object*)obj); }

  inline bool is_type(type_t type) const {
    if (obj)
      return (static_cast<object*>(obj)->type() == type);
    return false;
  }

  inline bool is_nil() const { return (obj == nullptr); }

private:
  object* detach(){
    object* _obj = obj;
    obj = nullptr;
    return _obj;
  }

  inline void inc_ref(){
#if !defined(FERRET_DISABLE_RC)
    // Only change if non-null
    if (obj) obj->inc_ref();
#endif
  }

  inline void dec_ref(){
#if !defined(FERRET_DISABLE_RC)
    // Only change if non-null
    if (obj){
      // Subtract and test if this was the last pointer.
      if (obj->dec_ref()){
        delete obj;
        obj = nullptr;
      }
    }
#endif
  }

  pointer_t obj;
};

template<>
inline seekable_i* var::cast<seekable_i>() const { return obj != nullptr ? obj->cast_seekable_i() : nullptr; }

template <typename rc>
bool object_i<rc>::equals(ref o) const {
  return (this == o.get());
}

#ifdef FERRET_STD_LIB
std::ostream &operator<<(std::ostream &os, var const &v) {
  v.stream_console();
  return os;
}
#endif

var two = obj<number>(2);
var some_nil = nil();

template<typename FT, typename... Args>
inline var obj(Args... args) {
  void * storage = FERRET_ALLOCATOR::allocate<FT>();
  return var(new(storage) FT(args...));
}

inline var nil(){
  return var();
}

(defn identity [x] x)

namespace memory {
  template <typename T>
  class pointer{
    T *ptr;

  public:

    inline explicit pointer(T *p = nullptr) : ptr(p){ }
    inline operator T* () const { return ptr; }

    inline pointer& operator= (T *other){
      ptr = other;
      return *this;
    }

    inline T *operator->() const { return ptr; }
  };
}

#if !defined(FERRET_RC_POLICY)
namespace memory {
  namespace gc {

#if !defined(FERRET_RC_TYPE)
  #define FERRET_RC_TYPE unsigned int
#endif

#if defined(FERRET_DISABLE_RC)

#define FERRET_RC_POLICY memory::gc::no_rc

    class no_rc{
    public:

      inline void inc_ref() { }
      inline bool dec_ref() { return false; }
    };

#else

    template<typename T>
    class rc{
    public:
      rc() : ref_count(0) {}

      inline void inc_ref() { ref_count++; }
      inline bool dec_ref() { return (--ref_count == 0); }

    private:
      T ref_count;
    };    

    #if defined(FERRET_DISABLE_MULTI_THREADING) || !defined(FERRET_STD_LIB)
      #define FERRET_RC_POLICY memory::gc::rc<FERRET_RC_TYPE>
    #endif

    #if defined(FERRET_STD_LIB) && !defined(FERRET_DISABLE_MULTI_THREADING)
      #define FERRET_RC_POLICY memory::gc::rc<::std::atomic<FERRET_RC_TYPE>>
    #endif
#endif
  }
}
#endif

namespace runtime{
  #undef min
  #undef max
  #undef abs

  template <typename T>
  static constexpr T max(T a, T b) {
    return a < b ? b : a;
  }

  template <typename T, typename... Ts>
  static constexpr T max(T a, Ts... bs) {
    return max(a, max(bs...));
  }

  template<typename T>
  constexpr T min(T a, T b){
    return ((a) < (b) ? (a) : (b));
  }

  template <typename T, typename... Ts>
  static constexpr T min(T a, Ts... bs) {
    return min(a, min(bs...));
  }

  template<typename T>
  constexpr T abs(T a){
    return ((a) < (T)0 ? -(a) : (a));
  }
}

(configure-runtime! FERRET_REAL_TYPE "ferret::fixed_real<32,8>")

(configure-runtime! FERRET_REAL_TYPE "ferret::fixed_real<32,0.01_QN>")

(configure-runtime! FERRET_REAL_TYPE    "ferret::fixed_real<24,16>"
                    FERRET_REAL_EPSILON 0.0001)

(cxx "static_assert(sizeof(int24_t) == 3 * sizeof(byte), \"\");")
(cxx "static_assert(sizeof(int24_t) ==     sizeof(real_t), \"\");")

(deftest math
  (is (=  3    (+  1.25   1.75)))
  (is (=  0.5  (- -1.25  -1.75)))
  (is (=  255  (+  254    1)))
  (is (=  255  (+  253.4  1.6)))
  (is (= -255  (- -254    1))))

(run-all-tests)

#include <cassert>
#include <runtime.h>

int main() {
  typedef ferret::fixed_real<32,8> fix_32;
  typedef ferret::fixed_real<64,8> fix_64;

  // Test Casting
  assert((char)          fix_32(char(25))  == char(25));
  assert((int)           fix_32(int(1024)) == int(1024));
  assert((long)          fix_64(long(25))  == long(25));
  assert((unsigned long) fix_64(2500UL)    == 2500UL);

  long max_int = std::numeric_limits<int>::max() + 1024L;
  assert((long)fix_64(max_int) == ((long)std::numeric_limits<int>::max() + 1024L));

  // Test Arithmetic
  fix_32 x;
  fix_32 y;
  x = 10;
  y = 0.250;
  assert(10.25 == (double)(x + y));

  x = fix_32(0);
  for(int i = 0; i < 100; i++)
    x += fix_32(0.0625);
  assert((double)x == 6.25);

  x = fix_32(22.75);
  y = fix_32(12.5);
  assert((double)(x + y) == 35.25);

  x = fix_32(22.75);
  y = fix_32(22.5);
  assert((double)(x - y) ==  0.25);
  assert((double)(y - x) == -0.25);

  x = fix_32(-0.25);
  y = fix_32(4);
  assert((double)(x / y) ==  -0.0625);

  x = fix_32(-0.0625);
  y = fix_32(-10);
  assert((double)(x - y) ==  9.9375);

  x = fix_32(9.9375);
  y = fix_32(-3);
  assert((double)(x * y) ==  -29.8125);

  x = fix_32(-29.8125);
  y = fix_32(0.1875);
  assert((double)(x - y) ==  -30);

  return 0;
}

#if !defined(__clang__)
constexpr auto operator "" _QN(long double x) -> int {
  return (int)::floor(::log(1.0/(double)x)/::log(2));
}
#endif

template<int bits> struct fixed_real_container;
template<> struct fixed_real_container<8>  { typedef int8_t  base_type;
                                             typedef int16_t next_type; };
template<> struct fixed_real_container<16> { typedef int16_t base_type;
                                             typedef int24_t next_type; };
template<> struct fixed_real_container<24> { typedef int24_t base_type;
                                             typedef int32_t next_type; };
template<> struct fixed_real_container<32> { typedef int32_t base_type;
                                             typedef int64_t next_type; };
template<> struct fixed_real_container<64> { typedef int64_t base_type;
                                             typedef int64_t next_type; };

#pragma pack(push, 1)
template<int bits, int exp>
class fixed_real {
  typedef fixed_real fixed;
  typedef typename fixed_real_container<bits>::base_type base;
  typedef typename fixed_real_container<bits>::next_type next;

  base m;
  static const int N      = (exp - 1);
  static const int factor = 1 << N;

  template<typename T>
  inline base from(T d) const { return (base)(d * factor); }

  template<typename T>
  inline T to_rational() const { return T(m) / factor; }

  template<typename T>
  inline T to_whole() const { return (T)(m >> N); }

public:

  //from types
  explicit fixed_real( )           : m(0) { }
  template<typename T>
  explicit fixed_real(T v)         : m(from<T>(v)) {}

  template<typename T>
  fixed& operator=(T v)        { m = from<T>(v); return *this; }

  //to types
  template<typename T>
  operator T()           const { return to_whole<T>();    }
  operator double()      const { return to_rational<double>(); }

  // operations
  fixed& operator+= (const fixed& x) { m += x.m; return *this; }
  fixed& operator-= (const fixed& x) { m -= x.m; return *this; }
  fixed& operator*= (const fixed& x) { m = (base)(((next)m * (next)x.m) >> N); return *this; }
  fixed& operator/= (const fixed& x) { m = (base)(((next)m * factor) / x.m); return *this; }
  fixed& operator*= (int x)          { m *= x; return *this; }
  fixed& operator/= (int x)          { m /= x; return *this; }
  fixed  operator-  ( )              { return fixed(-m); }

  // friend functions
  friend fixed operator+ (fixed x, const fixed& y) { return x += y; }
  friend fixed operator- (fixed x, const fixed& y) { return x -= y; }
  friend fixed operator* (fixed x, const fixed& y) { return x *= y; }
  friend fixed operator/ (fixed x, const fixed& y) { return x /= y; }

  // comparison operators
  friend bool operator== (const fixed& x, const fixed& y) { return x.m == y.m; }
  friend bool operator!= (const fixed& x, const fixed& y) { return x.m != y.m; }
  friend bool operator>  (const fixed& x, const fixed& y) { return x.m > y.m; }
  friend bool operator<  (const fixed& x, const fixed& y) { return x.m < y.m; }
  friend bool operator>= (const fixed& x, const fixed& y) { return x.m >= y.m; }
  friend bool operator<= (const fixed& x, const fixed& y) { return x.m <= y.m; }

#if defined(FERRET_STD_LIB)
  friend std::ostream& operator<< (std::ostream& stream, const fixed& x) {
    stream << (double)x;
    return stream;
  }
#endif
};
#pragma pack(pop)

#include <cassert>
#include <runtime.h>

int main() {
  using namespace ferret;

  //initializers
  assert((matrix::zeros(2,2)  == matrix::into<2,2>(0,0,0,0)));
  assert((matrix::ones(2,2)   == matrix::into<2,2>(1,1,1,1)));
  assert((matrix::eye(2)      == matrix::into<2,2>(1,0,0,1)));
  assert((matrix::full(2,2,4) == matrix::into<2,2>(4,4,4,4)));

  //shape
  assert((matrix::row_count(matrix::zeros(2,3))    == 2));
  assert((matrix::column_count(matrix::zeros(2,3)) == 3));

  //operations
  matrix ones  = matrix::ones(2,2);
  matrix zeros = matrix::zeros(2,2);
  matrix twos  = matrix::full(2,2,2);

  assert((ones - ones == zeros));
  assert((ones + ones == twos));
  assert((ones * 2    == twos));

  auto v3d = matrix::into<1,3>(0, 10, 0);

  assert((matrix::norm_euclidean(v3d) == 10));
  assert((matrix::normalise(v3d)      == matrix::into<1,3>(0, 1, 0)));
  return 0;
}

class matrix {
  //row-major
  array<real_t> data;
  //shape
  size_t  rows{0};
  size_t  cols{0};

  inline static void into_aux(matrix &){ }

  template<typename... Args>
  inline static void into_aux(matrix &m, real_t first, Args... rest){
    m.data[m.data.size() - sizeof...(rest) - 1] = first;
    into_aux(m, rest...);
  }

public:
  inline matrix(size_t r = 0, size_t c = 0) :
    data(r * c), rows(r) , cols(c) { }

  template<typename... Args>
  inline matrix(size_t rows, size_t cols, Args... elements)
    : matrix(rows,cols) {
    into_aux(*this, elements...);
  }

  inline matrix(matrix&& m) :
    data(m.data), rows(m.rows), cols(m.cols) { }

  inline matrix(matrix& m)
    : matrix(m.rows,m.cols){
    for(size_t i = 0; i < data.size(); i++)
      data[i] = m.data[i];
  }

  inline matrix operator+ (const matrix& m) const {
    matrix sum(rows,cols);
    for(size_t i = 0; i < data.size(); i++)
      sum.data[i] = data[i] + m.data[i];
    return sum;
  }

  inline matrix operator- (const matrix& m) const {
    matrix diff(rows,cols);
    for(size_t i = 0; i < data.size(); i++)
      diff.data[i] = data[i] - m.data[i];
    return diff;
  }

  matrix operator* (const matrix& m) const {
    matrix mul = matrix::zeros(rows, m.cols);

    if (cols != m.rows)
      return mul;

    for (size_t i = 0; i < rows; i++) {
      for (size_t j = 0; j < m.cols; j++) {
        for (size_t k = 0; k < m.rows; k++) {
          mul(i,j, mul(i,j) + operator()(i,k) * m(k,j));
        }
      }
    }

    return mul;
  }

  matrix operator* (const real_t& val) const {
    matrix mul(rows,cols);
    for(size_t i = 0; i < data.size(); i++)
      mul.data[i] = data[i] * val;
    return mul;
  }

  inline real_t operator()(size_t row, size_t col) const {
    return data[row * cols + col];
  }

  inline void operator()(size_t row, size_t col, real_t val) {
    data[row * cols + col] = val;
  }

  inline matrix& operator=(matrix&& x){
    data = array<real_t>(x.data);
    rows = x.rows;
    cols = x.cols;
    return *this;
  }

  inline bool operator ==(const matrix& m) const {
    for (size_t i = 0; i < data.size(); i++)
      if (data[i] != m.data[i])
        return false;
    return true;
  }

#if defined(FERRET_STD_LIB)
  friend std::ostream& operator<< (std::ostream& stream, const matrix& x) {
    stream << "[";
    for (size_t r = 0; r < x.rows; r++){
      stream << "[";
      stream << x(r, 0);
      for (size_t c = 1; c < x.cols; c++)
        stream << " " << x(r,c);
      stream << "]";
    }
    return stream << "]";
  }
#endif

  inline static matrix empty(size_t r = 0, size_t c = 0) {
    return matrix(r,c);
  }

  inline static void fill(matrix& m, real_t val) {
    for(size_t i = 0; i < m.data.size(); i++)
      m.data[i] = val;
  }

  inline static matrix zeros(size_t r = 0, size_t c = 0) {
    matrix m(r,c);
    fill(m, real_t(0));
    return m;
  }

  inline static matrix ones(size_t r = 0, size_t c = 0) {
    matrix m(r,c);
    fill(m, real_t(1));
    return m;
  }

  inline static matrix full(size_t r = 0, size_t c = 0, real_t v = real_t(0)) {
    matrix m(r,c);
    fill(m, v);
    return m;
  }

  static matrix eye(size_t n = 1){
    matrix m = matrix::zeros(n,n);

    for(size_t r = 0; r < m.rows; r++)
      m(r,r,real_t(1));

    return m;
  }

  template<size_t rows, size_t cols, typename... Args>
  inline static matrix into(Args... rest){
    matrix m(rows, cols);
    into_aux(m, rest...);
    return m;
  }

  inline static size_t row_count(const matrix& m){
    return m.rows;
  }

  inline static size_t column_count(const matrix& m){
    return m.cols;
  }

  static real_t norm_euclidean(const matrix& m){
    real_t norm = real_t(0);

    for(size_t i = 0; i < m.data.size(); i++){
      norm += m.data[i] * m.data[i];
    }

    return real_t(sqrt((double)norm));
  }

  static matrix normalise(const matrix& m){
    real_t mag = matrix::norm_euclidean(m);
    matrix norm = matrix::zeros(m.rows,m.cols);

    if (mag == real_t(0))
      return norm;

    for(size_t i = 0; i < m.data.size(); i++)
      norm.data[i] = m.data[i] / mag;

    return norm;
  }
};

constexpr auto operator "" _MB( unsigned long long const x ) -> long {
  return 1024L * 1024L * (long)x;
}

constexpr auto operator "" _KB( unsigned long long const x ) -> long {
  return 1024L * (long)x;
}

constexpr auto operator "" _pi(long double x) -> double {
  return 3.14159265358979323846 * (double)x;
}

constexpr auto operator "" _pi(unsigned long long int  x) -> double {
  return 1.0_pi * (double)x;
}

constexpr auto operator "" _deg(long double x) -> double {
  return (1.0_pi * (double)x) / 180;
}

constexpr auto operator "" _deg(unsigned long long int  x) -> double {
  return 1.0_deg * (double)x;
}

typedef uint8_t byte;

#pragma pack(push, 1)
class int24_t {
protected:
  byte word[3];
public:
  int24_t(){ }

  template<typename T>
  explicit int24_t( T const & val ) {
    *this   = (int32_t)val;
  }

  int24_t( const int24_t& val ) {
    *this   = val;
  }

  operator int32_t() const {
    if (word[2] & 0x80) { // negative? - then sign extend.
      return
        (int32_t)(((uint32_t)0xff    << 24) |
                  ((uint32_t)word[2] << 16) |
                  ((uint32_t)word[1] << 8)  |
                  ((uint32_t)word[0] << 0));
    }else{
      return
        (int32_t)(((uint32_t)word[2] << 16) |
                  ((uint32_t)word[1] << 8)  |
                  ((uint32_t)word[0] << 0));
    }
  }

  int24_t& operator =( const int24_t& input ) {
    word[0]   = input.word[0];
    word[1]   = input.word[1];
    word[2]   = input.word[2];

    return *this;
  }

  int24_t& operator =( const int32_t input ) {
    word[0]   = ((byte*)&input)[0];
    word[1]   = ((byte*)&input)[1];
    word[2]   = ((byte*)&input)[2];

    return *this;
  }

  int24_t operator +( const int24_t& val ) const {
    return int24_t( (int32_t)*this + (int32_t)val );
  }

  int24_t operator -( const int24_t& val ) const {
    return int24_t( (int32_t)*this - (int32_t)val );
  }

  int24_t operator *( const int24_t& val ) const {
    return int24_t( (int32_t)*this * (int32_t)val );
  }

  int24_t operator /( const int24_t& val ) const {
    return int24_t( (int32_t)*this / (int32_t)val );
  }

  int24_t& operator +=( const int24_t& val ) {
    *this   = *this + val;
    return *this;
  }

  int24_t& operator -=( const int24_t& val ) {
    *this   = *this - val;
    return *this;
  }

  int24_t& operator *=( const int24_t& val ) {
    *this   = *this * val;
    return *this;
  }

  int24_t& operator /=( const int24_t& val ) {
    *this   = *this / val;
    return *this;
  }

  int24_t operator -() {
    return int24_t( -(int32_t)*this );
  }

  bool operator ==( const int24_t& val ) const {
    return (int32_t)*this == (int32_t)val;
  }

  bool operator !=( const int24_t& val ) const {
    return (int32_t)*this != (int32_t)val;
  }

  bool operator >=( const int24_t& val ) const {
    return (int32_t)*this >= (int32_t)val;
  }

  bool operator <=( const int24_t& val ) const {
    return (int32_t)*this <= (int32_t)val;
  }

  bool operator >( const int24_t& val ) const {
    return (int32_t)*this > (int32_t)val;
  }

  bool operator <( const int24_t& val ) const {
    return (int32_t)*this < (int32_t)val;
  }
};
#pragma pack(pop)