jtkDvlp · November 23, 2020 08:08 · Nov 23, 2020
diff --git a/binarygcode.read.clj b/binarygcode.read.clj
@@ -0,0 +1,136 @@
+(ns jtk-dvlp.threed-wifi.binarygcode.read
+  (:require
+   [clojure.java.io :as io]
+   [clojure.string :as str]))
+
+
+(defn bytes-seq
+  [x & opts]
+  (lazy-seq
+    (when-let [stream (if (instance? java.io.InputStream x) x (apply io/input-stream x opts))]
+      (try
+        (if (> (.available stream) 0)
+          (cons (.read stream) (bytes-seq stream))
+          (.close stream))
+        (catch Throwable e
+          (.close stream)
+          (throw e))))))
+
+(defn- bits->integer
+  [size bits]
+  (let [bits (take size bits)]
+    (when (>= (count bits) size)
+      (->> bits
+           (reverse)
+           (reduce
+            (fn [byte bit]
+              (-> byte
+                  (bit-shift-left 1)
+                  (bit-or (if bit 1 0))))
+            0)
+           (unchecked-int)))))
+
+(defn- bits->float
+  [size bits]
+  (->> bits
+       (bits->integer size)
+       (#(Float/intBitsToFloat %))))
+
+(defn- parse-command-letter
+  [{:keys [bits] :as context}]
+  (when-let [letter (some->> bits (bits->integer 4) (#(nth ["G" "M" "T"] % nil)))]
+    (-> context
+        (assoc :letter letter)
+        (update :bits #(drop 4 %)))))
+
+(defn- parse-command-number
+  [{:keys [bits] :as context}]
+  (when-let [number (some->> bits (bits->integer 10))]
+    (-> context
+        (assoc :number number)
+        (update :bits #(drop 10 %)))))
+
+(defn- parse-command
+  [context]
+  (when-let [{:keys [letter number bits]}
+             (some-> context
+                     (parse-command-letter)
+                     (parse-command-number))]
+
+    (-> context
+        (assoc :bits bits)
+        (assoc-in [:command :letter] letter)
+        (assoc-in [:command :number] number))))
+
+(defn- parse-argument-letter
+  [{:keys [bits] :as context}]
+  (when-let [letter (some->> bits (bits->integer 4) (#(nth [nil nil nil "F" "X" "Y" "Z" "E" "S"] % nil)))]
+    (-> context
+        (assoc :letter letter)
+        (update :bits #(drop 4 %)))))
+
+(defn- parse-argument-number
+  [{:keys [bits] :as context}]
+  (if-let [number (some->> bits (bits->float 32))]
+    (-> context
+        (assoc-in [:number] number)
+        (update :bits #(drop 32 %)))
+    context))
+
+(defn- parse-argument
+  [context]
+  (when-let [{:keys [letter number bits]}
+             (some-> context
+                     (parse-argument-letter)
+                     (parse-argument-number))]
+
+    (-> context
+        (assoc :bits bits)
+        (assoc-in [:argument :letter] letter)
+        (assoc-in [:argument :number] number))))
+
+(defn- parse-arguments
+  [context]
+  (loop [context context]
+    (if-let [{:keys [argument bits]} (parse-argument context)]
+      (-> context
+          (assoc :bits bits)
+          (update :arguments conj argument)
+          (recur))
+      context)))
+
+(defn- bits->gocde-line
+  [context]
+  (some-> context
+          (parse-command)
+          (parse-arguments)))
+
+(defn- bits->gcode-lines-seq
+  [bits]
+  (lazy-seq
+    (when-let [stream (if (map? bits) bits (bits->gocde-line {:bits bits}))]
+      (cons (dissoc stream :bits)
+            (-> stream
+                (select-keys [:bits])
+                (bits->gocde-line)
+                (bits->gcode-lines-seq))))))
+
+(defn- byte->bits
+  [byte]
+  (map (partial bit-test byte) (range 8)))
+
+(defn gcode-lines-seq
+  [x]
+  (->> (if (sequential? x) x (bytes-seq x))
+       (mapcat byte->bits)
+       (bits->gcode-lines-seq)))
+
+(defn ->gcode-str
+  [{:keys [command arguments]}]
+  (let [->letter-number-str
+        #(str (:letter %) (:number %))]
+
+    (->> (reverse arguments)
+         (cons command)
+         (map ->letter-number-str)
+         (str/join " "))))
diff --git a/binarygcode.write.clj b/binarygcode.write.clj
@@ -0,0 +1,114 @@
+(ns jtk-dvlp.threed-wifi.binarygcode.write
+  (:require
+   [clojure.java.io :as io]
+   [clojure.string :as str]
+
+   [instaparse.core :as insta
+    :refer [defparser]]))
+
+(defn apply-parser
+  [parser string]
+  (let [parsed-data
+        (-> string
+            (str/trim)
+            (parser))]
+
+    (when-not (insta/failure? parsed-data)
+      parsed-data)))
+
+(defn ->map [[_group & entries]]
+  (into {} entries))
+
+(defparser command-parser
+  "<result> = command (space argument)*
+   command = letter number
+   argument = letter number?
+   letter = #'[GMTFXYZES]'
+   number = (integer|float)
+   integer = #'-?\\d+'
+   float = #'-?\\d+(\\.\\d+)?'
+   <space> = <#'\\s+'>")
+
+(defn parse-gcode-line
+  [string]
+  (some->> string
+           (apply-parser command-parser)
+           (insta/transform {:integer read-string
+                             :float read-string})
+           ((fn [[command & arguments]]
+              {:command (->map command)
+
+               :arguments
+               (mapv ->map arguments)}))))
+
+(defn- conj-bits
+  [size bits x]
+  (->> size
+       (range)
+       (map (partial bit-test x))
+       (concat bits)))
+
+(defn- conj-command-letter
+  [bits letter]
+  (case letter
+    "G" (conj-bits 4 bits 0)
+    "M" (conj-bits 4 bits 1)
+    "T" (conj-bits 4 bits 2)))
+
+(def ^:private conj-command-number
+  (partial conj-bits 10))
+
+(defn- conj-command
+  [bits {:keys [letter number]}]
+  (-> bits
+      (conj-command-letter letter)
+      (conj-command-number number)))
+
+(defn- conj-argument-letter
+  [bits letter]
+  (case letter
+    "F" (conj-bits 4 bits 3)
+    "X" (conj-bits 4 bits 4)
+    "Y" (conj-bits 4 bits 5)
+    "Z" (conj-bits 4 bits 6)
+    "E" (conj-bits 4 bits 7)
+    "S" (conj-bits 4 bits 8)))
+
+(defn- conj-argument-number
+  [bits number]
+  (->> number
+       (#(Float/floatToRawIntBits %))
+       (conj-bits 32 bits)))
+
+(defn- conj-argument
+  [bits {:keys [letter number]}]
+  (-> bits
+      (conj-argument-letter letter)
+      (conj-argument-number (or number 0))))
+
+(defn- conj-arguments
+  [bits arguments]
+  (reduce conj-argument bits arguments))
+
+(defn- gcode-line->bits
+  [{:keys [command arguments]}]
+  (-> []
+      (conj-command command)
+      (conj-arguments arguments)))
+
+(defn- bits->byte
+  [bits]
+  (reduce
+   (fn [byte bit]
+     (-> byte
+         (bit-shift-left 1)
+         (bit-or (if bit 1 0))))
+   0 (reverse (take 8 (concat bits (repeat 0))))))
+
+(defn gcode-bytes-seq
+  [x]
+  (->> (if (sequential? x) x (line-seq (io/reader x)))
+       (map parse-gcode-line)
+       (mapcat gcode-line->bits)
+       (partition-all 8)
+       (map bits->byte)))