An _in-progress_ implementation of A.K.Dewdney's "Corewar" in ClojureScript. There are many things that don't quite work properly yet, such as handling when a redcode assembly program is terminated. By default four (non-selectable) redcode programs are pitted against each other - at some point these will be loaded at random from a hill. The inst…

_corewar.cljs

(ns corewar.gui
  (:require
    [clojure.string :as str]
    [jayq.core :refer [show]]
    [enchilada :refer [canvas ctx canvas-size]]
    [corewar.memory :as mem]
    [corewar.assembler :as asm]
    [corewar.instruction-set :as instr]
    [corewar.virtual-machine :as vm]
    [corewar.redcode :as red]
    [big-bang.core :refer [big-bang]]
    [monet.canvas :refer [fill-style fill-rect fill
                          begin-path close-path move-to line-to
                          stroke stroke-style stroke-rect
                          save restore translate
                          text text-align text-baseline
                          ]]))

(defn draw-memory-cell [ctx mem-size grid-size offset color]
  (let [square-size (dec grid-size)
        x (inc (* grid-size (+ 2 (mod offset 96))))
        y (inc (* grid-size (+ 2 (quot offset 96))))]
    (->
      ctx
      (fill-style color)
      (fill-rect {:x x :y y :w square-size :h square-size}))))

(defn draw-memory-grid [ctx mem-size grid-size]
  (let [square-size (dec grid-size)]
    (->
      ctx
      (stroke-style :lightgrey)
      (fill-style :white))

    (dotimes [i mem-size]
      (let [x (* grid-size (+ 2 (mod i 96)))
            y (* grid-size (+ 2 (quot i 96)))]
        (->
          ctx
          (stroke-rect {:x x :y y :w grid-size :h grid-size})
          (fill-rect {:x (inc x) :y (inc y) :w square-size :h square-size})))))
    ctx)


(defn hex [n]
  (str "0x" (str/upper-case (.toString n 16))))

(defn disassemble [addr memory]
  (let [value (get memory addr)]
    (instr/to-string value)))

(defn draw-disassembly [ctx {:keys [id name author strategy color executed memory]}]
  (->
    ctx
    (save)
    (translate (+ 24 (* id 192)) 376)
    (fill-style color)
    (fill-rect {:x 0 :y 0 :w 172 :h 208})
    (fill-style :#333)
    (text {:text (str name " [" author "]") :x 4 :y 12}))

  (loop [y 200
         addr executed]
    (if (or (neg? y) (empty? addr))
      (restore ctx)
      (do
        (text ctx {:text (hex (first addr)) :x 4 :y y})
        (text ctx {:text (disassemble (first addr) memory) :x 64 :y y})
        (recur
          (- y 10)
          (next addr))))))

(defn rotate [queue]
  (conj
    (vec (next queue))
    (first queue)))

(defn update-state [event {:keys [contexts memory] :as world-state}]
  (let [context (assoc (first contexts) :memory memory)
        result (vm/execute-program context 1)]
    (->
      world-state
      (assoc
        :last-result result
        :memory (:memory result)
        :contexts (conj
                    (vec (next contexts))
                    result)))))

(defn render [{:keys [last-result] :as world-state}]
  (if-not last-result
    (draw-memory-grid ctx 4096 8)
    (do
      (draw-disassembly ctx (:last-result world-state))
      (draw-memory-cell ctx 4096 8 (first (:executed last-result)) (:color last-result))
      (doseq [mem-locn (:updated last-result)]
        (draw-memory-cell ctx 4096 8 mem-locn (:color last-result))
        ))))

(show canvas)
(big-bang
  :initial-state (mem/initial-state 4096
                    (asm/assemble red/dwarf)
                    (asm/assemble red/imp)
                    (asm/assemble red/sleepy)
                    (asm/assemble red/dwarf))
  :on-tick update-state
  :tick-interval 250
  :to-draw render)

addressing_mode.cljs

(ns corewar.addressing-mode
  "Encodes the addressing mode as part of the assembly process.

   There are various ways of specifying memory addresses in an
   assembly-language program. In order to make the execution of a Redcode
   program independent of its position in memory, a special form of relative
   addressing is used. Again, your version of Redcode may have different
   addressing modes or additional ones, although you should be aware when you
   choose modes that Mars will load your Redcode program at an address in CORE
   that cannot be predicted in advance."
 (:require
   [corewar.constants :as const]
   [corewar.compat :refer [parse-int]]))

(def encoded-form {
  :immediate 0x00
  :relative  0x01
  :indirect  0x02
  :undefined 0x03
})

(def repr {
  :immediate #(str \# %)
  :relative str
  :indirect #(str \@ %)
  :undefined (constantly nil)
})

(def ^:private inverted-form (into {} (map (fn [[k v]] [v k]) encoded-form)))

(defn ^:private encode [addressing-mode value]
  (bit-or
    (bit-shift-left (encoded-form addressing-mode) const/operand-bits)
    (bit-and const/value-mask value)))

(def undefined
  (encode :undefined 0))

(defn immediate
  "The number is the operand"
  [value]
  (encode :immediate value))

(defn relative
  "The number specifies an offset from the current instruction. Mars
   adds the offset to the address of the current instruction; the
   number stored at the location reached in this way is the operand."
  [value]
  (encode :relative value))

(defn indirect
  "The number specifies an offset from the current instruction to a location
   where the relative address of the operand is found. Mars adds the offset to
   the address of the current instruction and retrieves the number stored at
   the specified location; this number is then interpreted as an offset from
   its own address. The number found at this second location is the operand."
  [value]
  (encode :indirect value))

(defn addressing-mode [operand]
  (when operand
    (inverted-form
      (bit-shift-right
        operand
        const/operand-bits))))

(defn value [operand]
  (bit-and const/value-mask operand))

(defn valid? [operand]
  (not (nil? (addressing-mode operand))))

(defn twos-complement [value]
  (if (> value (/ const/core-size 2))
    (- value const/core-size)
    value))

(defn to-string [operand]
  (when operand
    (when-let [addr-mode (addressing-mode operand)]
      ((repr addr-mode) (twos-complement (value operand))))))


(defn parse [operand]
  (let [operand (str operand)]
    (if (empty? operand)
      undefined
      (condp = (first operand)
        \@ (indirect (parse-int (subs operand 1)))
        \# (immediate (parse-int (subs operand 1)))
        (relative (parse-int operand))))))

assembler.cljs

(ns corewar.assembler
  (:require
    [clojure.string :as str]
    [corewar.instruction-set :as instr]
    [corewar.addressing-mode :as addr]
    [corewar.compat :refer [starts-with]]))

(defn ^:private ignore-exclusions? [^String prog-line]
  (or
    (starts-with prog-line ";redcode-")
    (starts-with prog-line ";name ")
    (starts-with prog-line ";author ")
    (starts-with prog-line ";strategy ")))

(defn ^:private strip-comment [^String prog-line]
  (let [idx (.indexOf prog-line ";")]
    (if (or (neg? idx))
      prog-line
      (subs prog-line 0 idx))))

(defn ^:private strip-non-metadata-comment [prog-line]
  (if (ignore-exclusions? prog-line)
    prog-line
    (strip-comment prog-line)))

(defn ^:private read-source [source-code]
  (->>
    (str/split-lines source-code)
    (map (comp str/trim strip-non-metadata-comment))
    (remove empty?)))

(defn ^:private add-line-numbers [program]
  (map vector (iterate inc 1) program))

(defn ^:private extract-label [[line-no prog-line]]
  (when-let [[_ label] (re-find #"^([a-zA-Z][a-zA-Z0-9_]*?):" prog-line)]
    [label line-no]))

(defn ^:private strip-label [prog-line]
  (if-let [[_ label stripped-code] (re-find #"(^[a-zA-Z][a-zA-Z0-9_]+:)?\s*(.*)" prog-line)]
    stripped-code
    prog-line))

(defn ^:private get-labels [annotated-program]
  (->>
    annotated-program
    (map extract-label)
    (remove nil?)
    (into {})))

(defn ^:private make-label-resolver [annotated-program]
  (let [symbol-table (get-labels annotated-program)]
    (fn [label line-no]
      (when-not (empty? label)
        (if-let [ln (symbol-table label)]
          (- ln line-no)
          label)))))

(defn ^:private metadata-scraper [[line-no prog-line] label-resolver]
  (when-let [[_ k v] (re-find #"^;([a-z]*)[ -]+(.*)" prog-line)]
    {(keyword k) v}))

(defn ^:private tokenize [prog-line]
  (->
    prog-line
    strip-label
    strip-comment
    str/trim
    (str/split #"[ ,\t]+")))

(defn ^:private pseudo-opcode [[line-no prog-line] label-resolver]
  (let [[opcode & operands] (tokenize prog-line)
        operands (map #(label-resolver % line-no) operands)]
    (condp = opcode
      "org" {:start (dec (first operands))}
      ; TODO : add other pseudo ops here
      nil)))

(defn ^:private assemble-instruction [[line-no prog-line] label-resolver]
  (let [[opcode & operands] (tokenize prog-line)
        operands (map #(label-resolver % line-no) operands)]
    (when (and opcode (pos? (count operands)))
      (when-let [instr (apply instr/parse opcode operands)]
        {:instr [instr]}))))

(defn ^:private parse-line [line label-resolver]
  (merge
    (metadata-scraper line label-resolver)
    (pseudo-opcode line label-resolver)
    (assemble-instruction line label-resolver)))

(defn assemble
  "Builds an assembly from the given redcode program. Returns a map comprising:

     :instr - a sequence of machine code instructions
     :start - an offset in :instr where the program should begin execution

   Optional:

     :name  - the redcode program data (scraped from metadata)
     :author - the prescribed author (scraped from metadata)
     :strategy - notes associated with the strategy employed (scraped from metadata)
     :redcode - the spec version used.  "
  [source-code]
  (let [annotated-program (add-line-numbers (read-source source-code))
        label-resolver (make-label-resolver annotated-program)]
    (->>
      annotated-program
      (map #(parse-line % label-resolver))
      (reduce (partial merge-with concat)))))

(defn disassemble
  "Takes a list of machine code instructions and produces an assembly listing"
  [machine-code]
  (map instr/to-string machine-code))

(comment

  (def assembly (assemble (slurp "resources/dwarf.red")))
  (disassemble (:instr assembly))

)

compat.cljs

(ns corewar.compat
  "Compatibility layer for clojure & clojurescript"
  (:require
    ;[clojure.tools.reader :as r]
    [cljs.reader :as r]))

(defn starts-with [s prefix]
  (let [slice (subs s 0 (min (count s) (count prefix)))]
    (= slice prefix)))

(defn parse-int [x]
  (if-not (number? x)
    (r/read-string x)
    x))

constants.cljs

(ns corewar.constants)

(def ^:const opcode-bits 4)
(def ^:const mode-bits 2)
(def ^:const operand-bits 12)

(def ^:const operand-position (+ operand-bits mode-bits))
(def ^:const opcode-position (* 2 operand-position))

(defn ^:private mask [bits]
  (dec (int (Math/pow 2 bits))))

(def ^:const core-size (int (Math/pow 2 operand-bits)))
(def ^:const value-mask (mask operand-bits))
(def ^:const opcode-mask (mask opcode-bits))
(def ^:const operand-mask (mask (+ operand-bits mode-bits)))

context.cljs

(ns corewar.context
  (:require
    [corewar.constants :as const]
    [corewar.instruction-set :as instr]))

(defn read-memory
  "Extracts the current instruction from the context, returns memory[index]"
  [{:keys [memory index]}]
  (memory index))

(defn write-memory
  "Updates the memory at the given address in the context. Also adds
   the address to an :updated vector"
  [context address value]
  (->
    context
    (assoc-in [:memory address] value)
    (update-in [:updated] conj address)))

(defn inc-index
  "Non-destructive incrementing update on the index/address-pointer, ensuring that the
   index always wraps round the limit of the memory"
  [{:keys [memory index] :as context}]
  (let [inc-mod  #(mod (inc %) const/core-size)]
    (->
      context
      (update-in [:index] inc-mod)
      (update-in [:executed] conj index))))

(defn set-index
  [{:keys [memory index] :as context} delta]
  (->
    context
    (assoc :index (mod (+ index delta) const/core-size))
    (update-in [:executed] conj index)))

exceptions.cljs

(ns corewar.exceptions
  (:require
    [corewar.instruction-set :as instr]))

(defn ^:private throw-illegal-argument [msg context]
  (let [index (:index context)
        memory (:memory context)
        instr (memory index)]
    (throw
      (IllegalArgumentException.
        (str msg " '" (instr/to-string instr) "' at memory location " index)))))

(defn invalid-addressing-mode [context]
  (throw-illegal-argument "Invalid addressing mode" context))

(defn invalid-instruction [context]
  (throw-illegal-argument "Cannot execute" context))

instuction_set.cljs

(ns corewar.instruction-set
  "Encodes the instruction set as part of the assembly process.

   Core War programs are written in an assembly-type language called Redcode.
   The eight instructions included in the version of the language presented
   here are by no means the only ones possible; indeed, the original
   implementation of Core War, done on a minicomputer, had a larger instruction
   set. If there are many kinds of instructions, however, the encoded form of
   each instruction takes up more space, and so the area of memory needed for
   CORE must be larger. Mars, the program that interprets Redcode programs,
   also grows as the size of the instruction set increases. The complexity of
   your Core War implementation may be constrained by the amount of memory
   available in your computer.

   If you choose to a create your own Redcode instruction set, two points
   should be kept in mind. First, each Redcode instruction must occupy a single
   location in CORE. In many assembly languages an instruction can extend over
   multiple addresses, but not in Redcode. Second, there are no registers
   available for Redcode programs; all data are kept in CORE and manipulated
   there."
  (:require
    [clojure.string :as str]
    [corewar.constants :as const]
    [corewar.addressing-mode :as addr]))

(def encoded-form {
  :dat 0x00
  :mov 0x01
  :add 0x02
  :sub 0x03
  :jmp 0x04
  :jmz 0x05
  :djz 0x06
  :cmp 0x07
})

(def ^:private inverted-form (into {} (map (fn [[k v]] [v k]) encoded-form)))

(defn ^:private encode [opcode a b]
  (when-let [code (encoded-form opcode)]
    (bit-or
      (bit-shift-left (bit-and code const/opcode-mask) const/opcode-position)
      (bit-shift-left (bit-and a const/operand-mask) const/operand-position)
      (bit-shift-left (bit-and b const/operand-mask) 0))))

(defn dat
  "Initialize location to value B."
  ([b] (dat addr/undefined b))
  ([a b] (encode :dat a b)))

(defn mov
  "Move A into location B."
  [a b]
  (encode :mov a b))

(defn add
  "Add operand A to contents of location B and store result in location B."
  [a b]
  (encode :add a b))

(defn sub
  "Subtract operand A to contents of location B and store result in location B."
  [a b]
  (encode :sub a b))

(defn jmp
  "Jump to location B."
  [b]
  (encode :jmp addr/undefined b))

(defn jmz
  "If operand A is 0, jump to location B; otherwise continue with next
   instruction."
  [a b]
  (encode :jmz a b))

(defn djz
  "Decrement contents of location A by 1. If location A now holds 0,
   jump to location B; otherwise continue with next instruction."
  [a b]
  (encode :djz a b))

(defn cmp
  "Compare operand A with operand B. If they are not equal, skip next
   instruction; otherwise continue with next instruction."
  [a b]
  (encode :cmp a b))

(defn opcode [instr]
  (inverted-form
    (bit-shift-right instr const/opcode-position)))

(defn operand-a [instr]
  (bit-and
    const/operand-mask
    (bit-shift-right instr const/operand-position)))

(defn operand-b [instr]
  (bit-and const/operand-mask instr))

(defn valid? [instr]
  (and
    (opcode instr)
    (valid? (operand-a instr))
    (valid? (operand-b instr))
    ; TODO: also need to cross-check A & B's addressing modes
    ))

(defn to-string [instr]
  (str/join " "
    (remove nil?
      (list
        (name (opcode instr))
        (addr/to-string (operand-a instr))
        (addr/to-string (operand-b instr))))))

(defn parse
  ([opcode operand-b]
   (parse opcode nil operand-b))
  ([opcode operand-a operand-b]
    (encode
      (keyword (str/lower-case opcode))
      (addr/parse operand-a)
      (addr/parse operand-b))))

memory.cljs

(ns corewar.memory
  "Responsible for loading programs into core memory at random
   non-overlapping start positions"
  (:require
    [clojure.set :refer [intersection]]))

(defn load-program [core [offset machine-code]]
  ; TODO - change to reduce-kv
  (if (empty? machine-code)
    core
    (recur
      (assoc (vec core) offset (first machine-code))
      [(mod (inc offset) (count core))    ; next offset
       (rest machine-code)])))            ; next machine instruction

(defn make-configurations [core-size program-sizes]
  (vec
    (repeatedly
      (count program-sizes)
      #(rand-int core-size))))

(defn clock-range
  "Clock arithmetic version of range"
  [start end max-size]
  (assert (pos? max-size))
  (assert (<= start end))
  (->>
    (range start end)
    (map #(mod % max-size))))

(defn overlapping?
  "Checks all combinations of configurations (+ sizes) to see if
   there is any overlapping between configurations."
  [core-size program-sizes configurations]
  (letfn [(build-range [x]
            (set (clock-range
                   (configurations x)
                   (+ (configurations x) (nth program-sizes x))
                   core-size)))]
    (not-every? empty?
      (for [j (range (count configurations))
            i (range j)]
        (intersection
          (build-range i)
          (build-range j))))))

(defn tabula-rasa-monte-carlo
  "Picks random configurations for the program start poisitions, checking for
   overlapping. Any overlap, and new configurations are chosen again using a
   Tabula Rasa strategy to ensure equi-probability principle (see: École
   Normale Supérieure course: Statistical Mechanics & Computations, tutorial 2)"
  [core-size program-sizes]
  (loop [configurations (make-configurations core-size program-sizes)]
    (if-not (overlapping? core-size program-sizes configurations)
      configurations
      (recur (make-configurations core-size program-sizes)))))

(defn zip [& colls]
  (apply map list colls))

(defn init-context [id assembly color start-posn]
  (assoc assembly
    :id id
    :color color
    :hist-size 17
    :index (+ start-posn (:start assembly))))

(defn initial-state [size & assemblies]
  (let [colors (shuffle
                 [:#E16889 :#FE853E :#6EC59B :#FDBA52 :#F5DED0
                  :#94614C :#2D97D3 :#48C3CB :#A9A6D3 :#C0C1BC ])
        ;colors [:#55FFBE :#FFE1DE :#92DCD8 :#F5DE7C :orange]
        start-positions (->> (map count assemblies)
                             (tabula-rasa-monte-carlo size))]
    {:contexts (mapv init-context (iterate inc 0) assemblies colors start-positions)
     :memory (->>
               (map :instr assemblies)
               (zip start-positions)
               (reduce load-program (repeat size 0))
               (vec))}))

redcode.cljs

(ns corewar.redcode)

; TODO: load these in via cljs-dataview


(def dwarf "
;redcode-88
;name Dwarf
;author A.K.Dewdney

        org dwarf

dwarf:  ADD #4, 3
        MOV 2, @2

; comment
        JMP dwarf
bomb:   DAT #0

        end")

(def imp "
;redcode-88
;name Imp
;author A.K.Dewdney

        org imp

imp:    MOV 0, 1
        end")

(def sleepy "
;redcode-94
;name Sleepy
;author John Q. Smith
;strategy bombing core

        org sleepy

sleepy: ADD #10, -1
        MOV 2, @-1
        JMP -2
        DAT #33, #33

end")

virtual_machine.cljs

(ns corewar.virtual-machine
  (:require
    [corewar.memory :as mem]
    [corewar.context :as ctx]
    [corewar.assembler :as asm]
    [corewar.exceptions :as ex]
    [corewar.constants :as const]
    [corewar.instruction-set :as instr]
    [corewar.addressing-mode :as addr]))

(defn ^:private operand-result
  ([value] (operand-result value nil))
  ([value address] {:value value :address address}))

(defn eval-operand
  "Returns the result of evaluating the operand against the memory:

     :immediate - no address;
                  value given is the field itself

     :relative  - address of operand is index + field;
                  value is the content of the memory at this address

     :indirect  - address is value of the pointer + content of location it points to;
                  value is the content of the memory at this address

   Returns a map with :value and :address keys.

   An operand with an invalid/undefined addressing mode will yield a nil result."
  [which-operand {:keys [memory index] :as context}]
  (let [instr   (ctx/read-memory context)
        operand (which-operand instr)]

    (case (addr/addressing-mode operand)

      :immediate
      (operand-result (addr/value operand))

      :relative
      (let [address  (mod (+ index (addr/value operand)) const/core-size)
            value    (memory address)]
        ;(println "relative: index =" index ", value" (addr/value operand))
        (operand-result value address))

      :indirect
      (let [pointer  (mod (+ index (addr/value operand)) const/core-size)
            address  (mod (+ pointer (memory pointer)) const/core-size)
            value    (memory address)]
        (operand-result value address))

      ; default
      nil)))

(defn ^:private eval-operands
  "Assembles the evaluated operands in a map like

     {:a {:value AX :address AY} :b {:value BX :address BY}}

   according to the addressing modes of the operands of the instruction
   at memory position :index in the context."
  [context]
  {:a (eval-operand instr/operand-a context)
   :b (eval-operand instr/operand-b context)})

(defn operand-accessor [context]
  (let [operands (eval-operands context)]
    ;(println operands)
    (fn [& path]
      (if-let [result (get-in operands path)]
        result
        (ex/invalid-addressing-mode context)))))

(defn execute-instr [context]
  (let [operand (operand-accessor context)
        instr   (ctx/read-memory context)]

    (case (instr/opcode instr)
      ; MOV: Move A into B, then continue to the next instruction
      :mov
      (let [address (operand :b :address)
            value   (operand :a :value)]
        (->
          context
          (ctx/write-memory address value)
          (ctx/inc-index)))

      ; ADD: Add A and B and store the result in B,
      ; then continue to the next instruction
      :add
      (let [address (operand :b :address)
            answer  (+ (operand :b :value) (operand :a :value))]
        (->
          context
          (ctx/write-memory address answer)
          (ctx/inc-index)))

      ; SUB: Subtract A from B and store the result in B,
      ; then continue to the next instruction
      :sub
      (let [address (operand :b :address)
            answer  (- (operand :b :value) (operand :a :value))]
        (->
          context
          (ctx/write-memory address answer)
          (ctx/inc-index)))

      ; JMP: Unconditionally jump to B
      :jmp
      (ctx/set-index context (-> instr instr/operand-b addr/value))

      ; JMZ: If A is zero, jump to B,
      ; else continue to the next instruction
      :jmz
      (if (zero? (operand :a :value))
        (ctx/set-index context (-> instr instr/operand-b addr/value))
        (ctx/inc-index context))

      ; DJZ: Decrement A and store the result.
      ; If the result is zero then jump to B,
      ; else continue to the next instruction
      :djz
      (let [address (operand :a :address)
            answer  (dec (operand :a :value))
            context (ctx/write-memory context address answer)]
        (if (zero? answer)
          (ctx/set-index context (-> instr instr/operand-b addr/value))
          (ctx/inc-index context)))

      ; CMP: If the operands are equal then skip the next instruction,
      ; else continue to the next instruction
      :cmp
      (if (= (operand :a :value) (operand :b :value))
        (ctx/set-index context 2)
        (ctx/inc-index context))

      ; default: report failure
      (ex/invalid-instruction context))))

(defn retain-n-historical [{:keys [executed hist-size]}]
  (take (or hist-size 4) executed))

(defn execute-program [context max-steps]
  (loop [ctx (assoc context :updated #{} :executed (retain-n-historical context))
         n max-steps]
    (if (zero? n)
      ctx
      (recur
        (execute-instr ctx)
        (dec n)))))

(comment

  (def assembly (asm/assemble (slurp "resources/imp.red")))
  (def assembly (asm/assemble (slurp "resources/sleepy.red")))
  (def state (mem/initial-state 200 assembly))

  (def context (assoc (first (:contexts state))
                      :memory (:memory state)
                      :executed (range 30)))

  (asm/disassemble (:instr assembly))
  (println context)
  (def result (execute-program context 1))
  (asm/disassemble (:memory result))
)