(ns clj-money.models.transactions-test
  (:require [clojure.test :refer :all]
            [environ.core :refer [env]]
            [clojure.pprint :refer [pprint]]
            [clj-time.core :as t]
            [clj-factory.core :refer [factory]]
            [clj-money.validation :as validation]
            [clj-money.models.users :as users]
            [clj-money.models.entities :as entities]
            [clj-money.models.accounts :as accounts]
            [clj-money.models.transactions :as transactions]
            [clj-money.factories.user-factory]
            [clj-money.factories.entity-factory]
            [clj-money.test-helpers :refer [reset-db
                                            assert-validation-error]]))

(def storage-spec (env :db))

(use-fixtures :each (partial reset-db storage-spec))

(def user (users/create storage-spec (factory :user)))
(def entity (entities/create storage-spec
                             (assoc (factory :entity) :user-id (:id user))))

(def account-defs
  [{:name "Checking"
    :type :asset}
   {:name "Salary"
    :type :income}
   {:name "Groceries"
    :type :expense}])

(defn test-context
  "Returns a context containing related models necessary to run the tests"
  []
  (let [accounts (zipmap [:checking :salary :groceries]
                         (->> account-defs
                              (map #(assoc % :entity-id (:id entity)))
                              (map #(accounts/create storage-spec %))))]
    {:accounts accounts
     :attributes {:transaction-date (t/local-date 2016 3 2)
                  :entity-id (:id entity)
                  :items [{:account-id (-> accounts :checking :id)
                           :action :debit
                           :amount (bigdec 1000)}
                          {:account-id (-> accounts :salary :id)
                           :action :credit
                           :amount (bigdec 1000)}]}}))

(deftest create-a-transaction
  (let [context (test-context)
        attributes (:attributes context)
        transaction (transactions/create storage-spec attributes)]
    (testing "return value includes the new id"
      (is (validation/valid? transaction))
      (is (number? (:id transaction)) "A map with the new ID is returned"))
    (testing "transaction can be retrieved"
      (let [retrieved (transactions/find-by-id storage-spec (:id transaction))]
        (is retrieved "The transaction is retrievable by ID")
        (is (= 2
               (count (:items retrieved))) "The items are returned with the transaction")))))

(deftest transaction-date-is-required
  (let [context (test-context)
        attributes (:attributes context)
        transaction (transactions/create storage-spec (dissoc attributes :transaction-date))]
    (is (validation/has-error? transaction :transaction-date))))

(deftest entity-id-is-required
  (let [context (test-context)
        attributes (:attributes context)
        transaction (transactions/create storage-spec (dissoc attributes :entity-id))]
    (is (validation/has-error? transaction :entity-id))))

(deftest item-account-id-is-required
  (let [context (test-context)
        attributes (:attributes context)
        transaction (transactions/create
                      storage-spec
                      (update-in attributes
                                 [:items 0]
                                 #(dissoc % :account-id)))]
    (is (validation/has-error? transaction :items))))

(deftest item-amount-is-required
  (let [context (test-context)
        attributes (:attributes context)
        transaction (transactions/create
                      storage-spec
                      (update-in attributes
                                 [:items 0]
                                 #(dissoc % :amount)))]
    (is (validation/has-error? transaction :items) "Validation error should be present")))

(deftest item-amount-must-be-greater-than-zero
  (let [context (test-context)
        attributes (:attributes context)
        transaction (transactions/create
                      storage-spec
                      (update-in attributes
                                 [:items 0]
                                 #(assoc % :amount (bigdec -1000))))]
    (is (validation/has-error? transaction :items) "Validation error should be present")))

(deftest item-action-is-required
  (let [context (test-context)
        attributes (:attributes context)
        transaction (transactions/create
                      storage-spec
                      (update-in attributes
                                 [:items 0]
                                 #(dissoc % :action)))]
    (is (validation/has-error? transaction :items) "Validation error should be present")))

(deftest item-action-must-be-debit-or-created
  (let [context (test-context)
        attributes (:attributes context)
        transaction (transactions/create
                      storage-spec
                      (update-in attributes
                                 [:items 0]
                                 #(assoc % :action :not-valid)))]
    (is (validation/has-error? transaction :items) "Validation error should be present")))

(deftest sum-of-debits-must-equal-sum-of-credits
  (let [context (test-context)
        attributes (:attributes context)
        transaction (transactions/create
                      storage-spec
                      (update-in attributes
                                 [:items 0]
                                 #(assoc % :amount (bigdec 1001))))]
    (is (validation/has-error? transaction :items) "Validation error should be present")))

(def balance-context
  {:entities [{:name "Personal"}]
   :accounts [{:name "Checking"
               :type :asset
               :entity-name "Personal"}
              {:name "Salary"
               :type :income
               :entity-name "Personal"}
              {:name "Groceries"
               :type :expense
               :entity-name "Personal"}]
   :transactions [{:transaction-date (t/local-date 2016 3 2)
                   :entity-name "Personal"
                   :items [{:action :debit
                            :account-name "Checking"
                            :amount 1000}
                           {:action :credit
                            :account-name "Salary"
                            :amount 1000}]}
                  {:transaction-date (t/local-date 2016 3 3)
                   :entity-name "Personal"
                   :items [{:action :debit
                            :account-name "Groceries"
                            :amount 100}
                           {:action :credit
                            :account-name "Checking"
                            :amount 100}]}]})

(defn realize-users
  [context]
  (throw (RuntimeException. "Not implemented")))

(defn realize-entities
  [context]
  (update-in context [:entities] (fn [entities]
                                 (map (fn [attributes]
                                        (entities/create storage-spec attributes))
                                      entities))))

(defn create-accounts
  [context accounts]
  (map (fn [attributes]
         (let [entity (->> context
                           :entities
                           (filter #(= (:name %) (:entity-name attributes))))]
           (accounts/create storage-spec (-> attributes
                                             (assoc :entity entity)
                                             (dissoc :entity-name)))))
       accounts))

(defn realize-accounts
  [context]
  (update-in context [:accounts] #(create-accounts context %)))

(defn realize
  "Realizes a test context"
  [input]
  (-> input
      realize-users
      realize-entities
      realize-accounts))

(deftest item-balances-are-set-when-saved
  (let [context (realize balance-context)
        [checking-items
         salary-items
         groceries-items] (map #(transactions/items-by-account storage-spec (:id %))
                               (:accounts context))]
    (is (= [(bigdec 1000) (bigdec 900)] (map :balance (checking-items))) "The checking account balances are correct")
    (is (= [(bigdec 1000)] (map :balance (salary-items))) "The salary account balances are correct")
    (is (= [(bigdec 100)] (map :balance (groceries-items))) "The groceries account balances are correct")))

; TODO Need to create the accounts for each test instead of once
(deftest item-indexes-are-set-when-saved
  (let [context (test-context)
        attributes (:attributes context)
        accounts (:accounts context)
        transaction (transactions/create
                      storage-spec
                      attributes)
        salary-item (->> transaction
                         :items
                         (filter #(= (:id (:salary accounts)) (:account-id %)))
                         first)
        checking-item (->> transaction
                         :items
                         (filter #(= (:id (:checking accounts)) (:account-id %)))
                         first)]
    (is (= 0 (:index salary-item)) "The salary transaction item has the correct index")
    (is (= 0 (:index checking-item)) "The checking transaction item has the correct index")))

(ns clj-money.models.transactions-test
  (:require [clojure.test :refer :all]
            [environ.core :refer [env]]
            [clojure.pprint :refer [pprint]]
            [clj-time.core :as t]
            [clj-factory.core :refer [factory]]
            [clj-money.validation :as validation]
            [clj-money.models.users :as users]
            [clj-money.models.entities :as entities]
            [clj-money.models.accounts :as accounts]
            [clj-money.models.transactions :as transactions]
            [clj-money.factories.user-factory]
            [clj-money.factories.entity-factory]
            [clj-money.serialization :as serialization]
            [clj-money.test-helpers :refer [reset-db
                                            assert-validation-error]]))

(def storage-spec (env :db))

(use-fixtures :each (partial reset-db storage-spec))

(def user (users/create storage-spec (factory :user)))
(def entity (entities/create storage-spec
                             (assoc (factory :entity) :user-id (:id user))))

(def account-defs
  [{:name "Checking"
    :type :asset}
   {:name "Salary"
    :type :income}
   {:name "Groceries"
    :type :expense}])

(defn test-context
  "Returns a context containing related models necessary to run the tests"
  []
  (let [accounts (zipmap [:checking :salary :groceries]
                         (->> account-defs
                              (map #(assoc % :entity-id (:id entity)))
                              (map #(accounts/create storage-spec %))))]
    {:accounts accounts
     :attributes {:transaction-date (t/local-date 2016 3 2)
                  :entity-id (:id entity)
                  :items [{:account-id (-> accounts :checking :id)
                           :action :debit
                           :amount (bigdec 1000)}
                          {:account-id (-> accounts :salary :id)
                           :action :credit
                           :amount (bigdec 1000)}]}}))

(deftest create-a-transaction
  (let [context (test-context)
        attributes (:attributes context)
        transaction (transactions/create storage-spec attributes)]
    (testing "return value includes the new id"
      (is (validation/valid? transaction))
      (is (number? (:id transaction)) "A map with the new ID is returned"))
    (testing "transaction can be retrieved"
      (let [retrieved (transactions/find-by-id storage-spec (:id transaction))]
        (is retrieved "The transaction is retrievable by ID")
        (is (= 2
               (count (:items retrieved))) "The items are returned with the transaction")))))

(deftest transaction-date-is-required
  (let [context (test-context)
        attributes (:attributes context)
        transaction (transactions/create storage-spec (dissoc attributes :transaction-date))]
    (is (validation/has-error? transaction :transaction-date))))

(deftest entity-id-is-required
  (let [context (test-context)
        attributes (:attributes context)
        transaction (transactions/create storage-spec (dissoc attributes :entity-id))]
    (is (validation/has-error? transaction :entity-id))))

(deftest item-account-id-is-required
  (let [context (test-context)
        attributes (:attributes context)
        transaction (transactions/create
                      storage-spec
                      (update-in attributes
                                 [:items 0]
                                 #(dissoc % :account-id)))]
    (is (validation/has-error? transaction :items))))

(deftest item-amount-is-required
  (let [context (test-context)
        attributes (:attributes context)
        transaction (transactions/create
                      storage-spec
                      (update-in attributes
                                 [:items 0]
                                 #(dissoc % :amount)))]
    (is (validation/has-error? transaction :items) "Validation error should be present")))

(deftest item-amount-must-be-greater-than-zero
  (let [context (test-context)
        attributes (:attributes context)
        transaction (transactions/create
                      storage-spec
                      (update-in attributes
                                 [:items 0]
                                 #(assoc % :amount (bigdec -1000))))]
    (is (validation/has-error? transaction :items) "Validation error should be present")))

(deftest item-action-is-required
  (let [context (test-context)
        attributes (:attributes context)
        transaction (transactions/create
                      storage-spec
                      (update-in attributes
                                 [:items 0]
                                 #(dissoc % :action)))]
    (is (validation/has-error? transaction :items) "Validation error should be present")))

(deftest item-action-must-be-debit-or-created
  (let [context (test-context)
        attributes (:attributes context)
        transaction (transactions/create
                      storage-spec
                      (update-in attributes
                                 [:items 0]
                                 #(assoc % :action :not-valid)))]
    (is (validation/has-error? transaction :items) "Validation error should be present")))

(deftest sum-of-debits-must-equal-sum-of-credits
  (let [context (test-context)
        attributes (:attributes context)
        transaction (transactions/create
                      storage-spec
                      (update-in attributes
                                 [:items 0]
                                 #(assoc % :amount (bigdec 1001))))]
    (is (validation/has-error? transaction :items) "Validation error should be present")))

(def balance-context
  {:users [(factory :user, {:email "john@doe.com"})]
   :entities [{:name "Personal"
               :user-id "john@doe.com"}]
   :accounts [{:name "Checking"
               :type :asset
               :entity-id "Personal"}
              {:name "Salary"
               :type :income
               :entity-id "Personal"}
              {:name "Groceries"
               :type :expense
               :entity-id "Personal"}]
   :transactions [{:transaction-date (t/local-date 2016 3 2)
                   :entity-id "Personal"
                   :items [{:action :debit
                            :account-id "Checking"
                            :amount 1000}
                           {:action :credit
                            :account-id "Salary"
                            :amount 1000}]}
                  {:transaction-date (t/local-date 2016 3 3)
                   :entity-id "Personal"
                   :items [{:action :debit
                            :account-id "Groceries"
                            :amount 100}
                           {:action :credit
                            :account-id "Checking"
                            :amount 100}]}]})

(deftest item-balances-are-set-when-saved
  (let [context (serialization/realize storage-spec balance-context)
        [checking-items
         salary-items
         groceries-items] (map #(transactions/items-by-account storage-spec (:id %))
                               (:accounts context))]
    (is (= [(bigdec 1000) (bigdec 900)] (map :balance checking-items))
        "The checking account balances are correct")
    (is (= [(bigdec 1000)] (map :balance (salary-items)))
          "The salary account balances are correct")
    (is (= [(bigdec 100)] (map :balance (groceries-items)))
          "The groceries account balances are correct")))

; TODO Need to create the accounts for each test instead of once
(deftest item-indexes-are-set-when-saved
  (let [context (test-context)
        attributes (:attributes context)
        accounts (:accounts context)
        transaction (transactions/create
                      storage-spec
                      attributes)
        salary-item (->> transaction
                         :items
                         (filter #(= (:id (:salary accounts)) (:account-id %)))
                         first)
        checking-item (->> transaction
                         :items
                         (filter #(= (:id (:checking accounts)) (:account-id %)))
                         first)]
    (is (= 0 (:index salary-item)) "The salary transaction item has the correct index")
    (is (= 0 (:index checking-item)) "The checking transaction item has the correct index")))

use serialization to setup tests

use serialization to setup tests


(ns workflo.macros.command.util
  (:require #?(:cljs [cljs.spec :as s]
               :clj  [clojure.spec :as s])
            #?(:cljs [cljs.spec.impl.gen :as gen]
               :clj  [clojure.spec.gen :as gen])
            [clojure.string :as string]
            [workflo.macros.query]
            [workflo.macros.specs.command]))

(s/def ::unqualified-symbol
  (s/with-gen
    (s/and symbol? #(not (some #{\/} (str %))))
    #(gen/fmap (comp symbol name) (s/gen symbol?))))

(s/fdef unqualify
  :args (s/cat :x symbol?)
  :ret  ::unqualified-symbol)

(defn unqualify
  "Take a symbol and generate a non-namespaced version of
   it by replacing slashes (/) with dashes (-)."
  [x]
  (let [x-ns   (namespace x)
        x-name (name x)]
    (if x-ns
      (symbol (str x-ns "-" x-name))
      (symbol x-name))))

(s/fdef prefix-form-name
  :args (s/cat :form-name ::unqualified-symbol
               :prefix ::unqualified-symbol)
  :ret  symbol?
  :fn   #(= (-> % :ret)
            (symbol (str (-> % :args :prefix) "-"
                         (-> % :args :form-name)))))

(defn prefix-form-name
  [form-name prefix]
  (symbol (str prefix "-" form-name)))

;;;; Utilities

(s/fdef bind-query-keys
  :args (s/cat :form-body
               (s/and seq?
                      :workflo.macros.specs.command/command-form-body)
               :query-keys
               :workflo.macros.query/map-destructuring-keys)
  :ret  :workflo.macros.specs.command/command-form-body)

(defn bind-query-keys
  [form-body query-keys]
  `((~'let [{:keys ~query-keys} ~'query-result]
     ~@form-body)))

(s/fdef form->defn
  :args (s/cat :form
               :workflo.macros.specs.command/conforming-command-form)
  :ret  (s/cat :defn #{'defn}
               :name ::unqualified-symbol
               :body (s/* ::s/any)))

(defn form->defn
  [form]
  `(~'defn ~(:form-name form)
    [~'query-result ~'data]
    ~@(:form-body form)))

(ns workflo.macros.command.util
  (:require #?(:cljs [cljs.spec :as s]
               :clj  [clojure.spec :as s])
            #?(:cljs [cljs.spec.impl.gen :as gen]
               :clj  [clojure.spec.gen :as gen])
            [clojure.string :as string]
            [workflo.macros.query]
            [workflo.macros.specs.command]))

(s/def ::unqualified-symbol
  (s/with-gen
    (s/and symbol? #(not (some #{\/} (str %))))
    #(gen/fmap (comp symbol name) (s/gen symbol?))))

(s/fdef unqualify
  :args (s/cat :x symbol?)
  :ret  ::unqualified-symbol)

(defn unqualify
  "Take a symbol and generate a non-namespaced version of
   it by replacing slashes (/) with dashes (-)."
  [x]
  (let [x-ns   (namespace x)
        x-name (string/replace (name x) "/" "")]
    (if x-ns
      (symbol (str x-ns "-" x-name))
      (symbol x-name))))

(s/fdef prefix-form-name
  :args (s/cat :form-name ::unqualified-symbol
               :prefix ::unqualified-symbol)
  :ret  symbol?
  :fn   #(= (-> % :ret)
            (symbol (str (-> % :args :prefix) "-"
                         (-> % :args :form-name)))))

(defn prefix-form-name
  [form-name prefix]
  (symbol (str prefix "-" form-name)))

;;;; Utilities

(s/fdef bind-query-keys
  :args (s/cat :form-body
               (s/and seq?
                      :workflo.macros.specs.command/command-form-body)
               :query-keys
               :workflo.macros.query/map-destructuring-keys)
  :ret  :workflo.macros.specs.command/command-form-body)

(defn bind-query-keys
  [form-body query-keys]
  `((~'let [{:keys ~query-keys} ~'query-result]
     ~@form-body)))

(s/fdef form->defn
  :args (s/cat :form
               :workflo.macros.specs.command/conforming-command-form)
  :ret  (s/cat :defn #{'defn}
               :name ::unqualified-symbol
               :body (s/* ::s/any)))

(defn form->defn
  [form]
  `(~'defn ~(:form-name form)
    [~'query-result ~'data]
    ~@(:form-body form)))

Fix unqualify to ensure there is no / in the resulting symbol


(ns server.system
  (:require
    [taoensso.timbre :as timbre]
    [com.stuartsierra.component :as c]
    [server.components.datasource :refer :all]
    [server.components.oracle :refer :all]
    [server.components.sparqlify :refer :all]
    [server.components.openrdf :refer :all]
    [server.components.ring :refer :all]
    [server.components.logging :refer :all]
    [server.routes.app :refer [app-fn]])
  (:gen-class))

(timbre/refer-timbre)

(defn new-system [db-opts app-fn ring-opts oracle-sparql-endpoint log-config sparqlify-opts openrdf-opts]
  (c/system-map
    :log (c/using (new-logger log-config) [])
    :datasource (c/using (new-datasource db-opts) [:log])
    :oracle (c/using (new-oracle oracle-sparql-endpoint) [:datasource :log])
    :sparqlify (c/using (new-sparqlify sparqlify-opts) [:datasource :log])
    :openrdf (c/using (new-openrdf openrdf-opts) [:log])
    :ring (c/using (new-ring app-fn ring-opts) [:datasource :oracle :sparqlify :openrdf :log])
    ))

;; configuration options

(def log-config {:ns-whitelist []
                 :ns-blacklist []})

(def db-opts {:driver ""
              :host ""
              :name ""
              :username ""
              :password ""})

(def ring-opts {:port 3000
                :open-browser? false
                :join true
                :auto-reload? true})

(def oracle-sparql-endpoint "http://localhost:8080/openrdf-sesame/repositories/lov")

(def sparqlify-opts {:host "http://localhost"
                     :port 7531})

(def openrdf-opts {:host "http://localhost:8080/openrdf-sesame"
                   :repo "r2r"
                   :base-uri "http://mycompany.com"})

(def system (atom (new-system
                    db-opts
                    #'app-fn
                    ring-opts
                    oracle-sparql-endpoint
                    log-config
                    sparqlify-opts
                    openrdf-opts)))

(def app (app-fn @system))

(defn init
  "called when web app is initialized"
  []
  (info "init r2r-designer/server.system")
  (when @system (swap! system c/start)))

(defn destroy
  "called when web app is destroyed"
  []
  (info "destroy r2r-designer/server.system")
  (when @system (swap! system c/stop)))

;; configure new system and start it
(defn -main []
  (info "calling server.system/-main")
  (init))

(ns server.system
  (:require
    [taoensso.timbre :as timbre]
    [com.stuartsierra.component :as c]
    [server.components.datasource :refer :all]
    [server.components.oracle :refer :all]
    [server.components.sparqlify :refer :all]
    [server.components.openrdf :refer :all]
    [server.components.ring :refer :all]
    [server.components.logging :refer :all]
    [server.routes.app :refer [app-fn]])
  (:gen-class))

(timbre/refer-timbre)

(defn new-system [db-opts app-fn ring-opts oracle-sparql-endpoint log-config sparqlify-opts openrdf-opts]
  (c/system-map
    :log (c/using (new-logger log-config) [])
    :datasource (c/using (new-datasource db-opts) [:log])
    :oracle (c/using (new-oracle oracle-sparql-endpoint) [:datasource :log])
    :sparqlify (c/using (new-sparqlify sparqlify-opts) [:datasource :log])
    :openrdf (c/using (new-openrdf openrdf-opts) [:log])
    :ring (c/using (new-ring app-fn ring-opts) [:datasource :oracle :sparqlify :openrdf :log])
    ))

;; configuration options

(def log-config {:ns-whitelist []
                 :ns-blacklist []})

(def db-opts {:driver ""
              :host ""
              :name ""
              :username ""
              :password ""})

(def ring-opts {:port 3000
                :open-browser? false
                :join true
                :auto-reload? true})

(def oracle-sparql-endpoint "http://localhost:8080/openrdf-sesame")

(def sparqlify-opts {:host "http://localhost"
                     :port 7531})

(def openrdf-opts {:host "http://localhost:8080/openrdf-sesame"
                   :repo "r2r"
                   :base-uri "http://mycompany.com"})

(def system (atom (new-system
                    db-opts
                    #'app-fn
                    ring-opts
                    oracle-sparql-endpoint
                    log-config
                    sparqlify-opts
                    openrdf-opts)))

(def app (app-fn @system))

(defn init
  "called when web app is initialized"
  []
  (info "init r2r-designer/server.system")
  (when @system (swap! system c/start)))

(defn destroy
  "called when web app is destroyed"
  []
  (info "destroy r2r-designer/server.system")
  (when @system (swap! system c/stop)))

;; configure new system and start it
(defn -main []
  (info "calling server.system/-main")
  (init))

correct sparql endpoint for standalone

correct sparql endpoint for standalone


(in-ns 'game.core)

(def cards-upgrades
  {"Akitaro Watanabe"
   {:events {:pre-rez-cost {:req (req (and (= (:type target) "ICE")
                                           (= (card->server state card) (card->server state target))))
                            :effect (effect (rez-cost-bonus -2))}}}

   "Amazon Industrial Zone"
   {:events
     {:corp-install  {:optional {:req (req (and (= (:type target) "ICE")
                                                (= (card->server state card) (card->server state target))))
                                 :prompt "Rez ICE with rez cost lowered by 3?"
                                 :yes-ability {:effect (effect (rez-cost-bonus -3) (rez target))}}}}}

   "Ash 2X3ZB9CY"
   {:abilities [{:label "Trace 4 - Prevent the Runner from accessing cards other than Ash 2X3ZB9CY"
                 :trace {:base 4
                         :effect (req (max-access state side 0)
                                      (let [ash card]
                                        (swap! state update-in [:run :run-effect]
                                               #(assoc % :successful-run
                                                         {:effect (effect (handle-access [ash])) :card ash}))))
                         :msg "prevent the Runner from accessing cards other than Ash 2X3ZB9CY"}}]}

   "Awakening Center"
   {:abilities [{:label "Host a piece of bioroid ICE"
                 :cost [:click 1] :prompt "Choose a piece of bioroid ICE to host on Awakening Center"
                 :choices (req (filter #(and (= (:type %) "ICE")
                                             (has? % :subtype "Bioroid")) (:hand corp)))
                 :msg "host a piece of bioroid ICE"
                 :effect (effect (trigger-event :corp-install target)
                                 (host card target {:facedown true}))}
                {:req (req (and this-server (= (get-in @state [:run :position]) 0)))
                 :label "Rez a hosted piece of bioroid ICE"
                 :prompt "Choose a piece of bioroid ICE to rez" :choices (req (:hosted card))
                 :msg (msg "lower the rez cost of " (:title target) " by 7 [Credits] and force the Runner to encounter it")
                 :effect (effect (rez-cost-bonus -7) (rez target)
                                 (update! (dissoc (get-card state target) :facedown))
                                 (register-events {:run-ends
                                                    {:effect (req (doseq [c (:hosted card)]
                                                                    (when (:rezzed c)
                                                                      (trash state side c)))
                                                                  (unregister-events state side card))}} card))}]
    :events {:run-ends nil}}

   "Bernice Mai"
   {:events {:successful-run {:req (req this-server)
                              :trace {:base 5 :msg "give the Runner 1 tag"
                                      :effect (effect (tag-runner :runner 1))}}}}

   "Breaker Bay Grid"
   {:events {:pre-rez-cost {:req (req (= (:zone card) (:zone target)))
                            :effect (effect (rez-cost-bonus -5))}}}

   "Caprice Nisei"
   {:abilities [{:msg "start a Psi game"
                 :psi {:not-equal {:msg "end the run" :effect (effect (end-run))}}}]}

   "ChiLo City Grid"
   {:events {:successful-trace {:req (req this-server)
                                :effect (effect (tag-runner :runner 1))
                                :msg "give the Runner 1 tag"}}}

   "Corporate Troubleshooter"
   {:abilities [{:label "[Trash]: Add strength to a rezzed ICE protecting this server" :choices :credit
                 :prompt "How many credits?"
                 :effect (req (let [boost target]
                                (resolve-ability
                                  state side
                                  {:choices {:req #(and (has? % :type "ICE") (:rezzed %))}
                                   :msg (msg "add " boost " strength to " (:title target))
                                   :effect (req (update! state side (assoc card :troubleshooter-target target
                                                                                :troubleshooter-amount boost))
                                                (trash state side (get-card state card))
                                                (update-ice-strength state side target))} card nil)))}]
    :events {:pre-ice-strength nil :runner-turn-ends nil :corp-turn-ends nil}
    :trash-effect
               {:effect (req (register-events
                               state side
                               (let [ct {:effect (req (unregister-events state side card)
                                                      (update! state side (dissoc card :troubleshooter-target))
                                                      (update-ice-strength state side (:troubleshooter-target card)))}]
                                 {:pre-ice-strength
                                                    {:req (req (= (:cid target) (:cid (:troubleshooter-target card))))
                                                     :effect (effect (ice-strength-bonus (:troubleshooter-amount card)))}
                                  :runner-turn-ends ct :corp-turn-ends ct}) card))}}

   "Crisium Grid"
   {:suppress {:successful-run {:req (req (and this-server (not= (:cid target) (:cid card))))}}
    :events {:successful-run {:req (req this-server)
                              :effect (req (swap! state update-in [:run :run-effect] dissoc :replace-access)
                                           (swap! state update-in [:run] dissoc :successful)
                                           (swap! state update-in [:runner :register :successful-run] #(butlast %)))}}}

   "Cyberdex Virus Suite"
   {:access {:optional {:prompt "Purge viruses with Cyberdex Virus Suite?"
                        :yes-ability {:msg (msg "purge viruses")
                                      :effect (effect (purge))}}}
    :abilities [{:label "[Trash]: Purge virus counters"
                 :msg "purge viruses" :effect (effect (purge) (trash card))}]}

   "Dedicated Technician Team"
   {:recurring 2}

   "Experiential Data"
   {:effect (req (update-ice-in-server state side (card->server state card)))
    :events {:pre-ice-strength {:req (req (= (card->server state card) (card->server state target)))
                                :effect (effect (ice-strength-bonus 1))}}
    :derez-effect {:effect (req (update-ice-in-server state side (card->server state card)))}
    :trash-effect {:effect (req (update-all-ice state side))}}

   "Expo Grid"
   {:events {:corp-turn-begins {:req (req (not (empty? (filter #(and (= (:type %) "Asset") (:rezzed %))
                                                               (get-in corp (:zone card))))))
                                :msg "gain 1 [Credits]" :effect (effect (gain :credit 1))}}}

   "Heinlein Grid"
   {:effect (req (add-watch state (keyword (str "heinlein" (:cid card)))
                   (fn [k ref old new]
                     (let [clicknew (get-in new [:runner :click])
                           clickold (get-in old [:runner :click])]
                       (when (< clicknew clickold)
                         (resolve-ability ref side
                           {:req (req this-server)
                            :msg (msg "force the Runner to lose all " (:credit runner) " [Credits]") :once :per-run
                            :effect (effect (lose :runner :credit :all))}
                          card nil))))))
    :leave-play (req (remove-watch state (keyword (str "heinlein" (:cid card)))))}

   "Hokusai Grid"
   {:events {:successful-run {:req (req this-server) :msg "do 1 net damage"
                              :effect (req (damage state side :net 1 {:card card}))}}}

   "Keegan Lane"
   {:abilities [{:label "[Trash], remove a tag: Trash a program"
                 :req (req (and this-server
                                (> (get-in @state [:runner :tag]) 0)
                                (not (empty? (filter #(has? % :type "Program") (all-installed state :runner))))))
                 :msg (msg "remove 1 tag")
                 :effect (req (resolve-ability state side trash-program card nil)
                              (trash state side card {:cause :ability-cost})
                              (lose state :runner :tag 1))}]}

   "Marcus Batty"
   {:abilities [{:label "[Trash]: Start a Psi game" :msg "start a Psi game"
                 :psi {:not-equal {:req (req this-server)
                                   :choices {:req #(and (has? % :type "ICE") (:rezzed %))}
                                   :msg (msg "resolve a subroutine on " (:title target))
                                   :effect (effect (trash card {:cause :ability-cost}))}}}]}

   "Midori"
   {:abilities
    [{:req (req this-server)
      :label "Swap the ICE being approached with a piece of ICE from HQ"
      :prompt "Choose a piece of ICE" :choices (req (filter #(has? % :type "ICE") (:hand corp))) :once :per-run
      :msg (msg "swap " (if (:rezzed current-ice) (:title current-ice) "the approached ICE") " with a piece of ICE from HQ")
      :effect (req (let [hqice target
                         c current-ice]
                     (resolve-ability state side
                       {:effect (req (let [newice (assoc hqice :zone (:zone c))
                                           cndx (ice-index state c)
                                           ices (get-in @state (cons :corp (:zone c)))
                                           newices (apply conj (subvec ices 0 cndx) newice (subvec ices cndx))]
                                       (swap! state assoc-in (cons :corp (:zone c)) newices)
                                       (swap! state update-in [:corp :hand]
                                              (fn [coll] (remove-once #(not= (:cid %) (:cid hqice)) coll)))
                                       (trigger-event state side :corp-install newice)
                                       (move state side c :hand)
                                       (update-run-ice state side)))} card nil)))}]}

   "NeoTokyo Grid"
   {:events {:advance {:req (req (= (butlast (:zone target)) (butlast (:zone card)))) :once :per-turn
                       :msg "gain 1 [Credits]" :effect (effect (gain :credit 1))}}}

   "Oaktown Grid"
   {:events {:pre-trash {:req (req (= (:zone card) (:zone target)))
                         :effect (effect (trash-cost-bonus 3))}}}

   "Off the Grid"
   {:events {:successful-run {:req (req (= target :hq))
                              :effect (req (trash state :corp card)
                                           (system-msg state :corp (str "trashes Off the Grid")))}}}

   "Old Hollywood Grid"
   (let [ab {:req (req (or (= (:zone card) (:zone target)) (= (central->zone (:zone target)) (butlast (:zone card)))))
             :effect (req (if (not (some #(= (:title %) (:title target)) (:scored runner)))
                            (prevent-steal state side)
                            (swap! state update-in [:runner :register] dissoc :cannot-steal)))}
         un {:effect (req (swap! state update-in [:runner :register] dissoc :cannot-steal))}]
     {:trash-effect
      {:req (req (= :servers (first (:previous-zone card))))
       :effect (effect (register-events {:pre-steal-cost (assoc ab :req (req (= (:zone target)
                                                                                (:previous-zone card))))
                                         :run-ends {:effect (req (unregister-events state side card)
                                                                 (swap! state update-in [:runner :register] dissoc
                                                                        :cannot-steal))}}
                                        (assoc card :zone '(:discard))))}
      :events {:pre-steal-cost ab :run-ends un}})

   "Panic Button"
   {:init {:root "HQ"} :abilities [{:cost [:credit 1] :effect (effect (draw))
                                    :req (req (and run (= (first (:server run)) :hq)))}]}

   "Product Placement"
   {:access {:req (req (not= (first (:zone card)) :discard))
             :msg "gain 2 [Credits]" :effect (effect (gain :corp :credit 2))}}

   "Red Herrings"
   (let [ab {:req (req (= (:zone card) (:zone target)))
             :effect (effect (steal-cost-bonus [:credit 5]))}]
     {:trash-effect {:req (req (= :servers (first (:previous-zone card))))
                     :effect (effect (register-events {:pre-steal-cost (assoc ab :req (req (= (:zone target)
                                                                                (:previous-zone card))))
                                                       :run-ends {:effect (effect (unregister-events card))}}
                                                      (assoc card :zone '(:discard))))}
      :events {:pre-steal-cost ab :run-ends nil}})

   "Research Station"
   {:init {:root "HQ"}
    :effect (effect (gain :max-hand-size 2)) :leave-play (effect (lose :max-hand-size 2))}

   "Rutherford Grid"
   {:events {:pre-init-trace {:req (req this-server)
                              :effect (effect (init-trace-bonus 2))}}}

   "Ryon Knight"
   {:abilities [{:label "[Trash]: Do 1 brain damage"
                 :msg "do 1 brain damage" :req (req (and this-server (zero? (:click runner))))
                 :effect (effect (trash card) (damage :brain 1 {:card card}))}]}

   "SanSan City Grid"
   {:effect (req (when-let [agenda (some #(when (= (:type %) "Agenda") %) (:content (card->server state card)))]
                   (update-advancement-cost state side agenda)))
    :events {:corp-install {:req (req (and (= (:type target) "Agenda") (= (:zone card) (:zone target))))
                            :effect (effect (update-advancement-cost target))}
             :pre-advancement-cost {:req (req (= (:zone card) (:zone target)))
                                    :effect (effect (advancement-cost-bonus -1))}}}

   "Self-destruct"
   {:abilities [{:req (req this-server)
                 :label "[Trash]: Trace X - Do 3 net damage"
                 :effect (req (let [serv (card->server state card)
                                    cards (concat (:ices serv) (:content serv))]
                                (trash state side card)
                                (doseq [c cards] (trash state side c))
                                (resolve-ability
                                  state side
                                  {:trace {:base (req (dec (count cards)))
                                           :effect (effect (damage :net 3 {:card card}))
                                           :msg "do 3 net damage"}} card nil)))}]}

   "Shell Corporation"
   {:abilities
    [{:cost [:click 1] :msg "store 3 [Credits]" :once :per-turn
      :effect (effect (add-prop card :counter 3))}
     {:cost [:click 1] :msg (msg "gain " (:counter card) " [Credits]") :once :per-turn
      :label "Take all credits"
      :effect (effect (gain :credit (:counter card)) (set-prop card :counter 0))}]}

   "Simone Diego"
   {:recurring 2}

   "Strongbox"
   (let [ab {:req (req (= (:zone card) (:zone target)))
             :effect (effect (steal-cost-bonus [:click 1]))}]
     {:trash-effect {:req (req (= :servers (first (:previous-zone card))))
                     :effect (effect (register-events {:pre-steal-cost (assoc ab :req (req (= (:zone target)
                                                                                (:previous-zone card))))
                                                       :run-ends {:effect (effect (unregister-events card))}}
                                                      (assoc card :zone '(:discard))))}
      :events {:pre-steal-cost ab :run-ends nil}})

   "The Twins"
   {:abilities [{:label "Reveal and trash a copy of the ICE just passed from HQ"
                 :req (req (and this-server
                                (> (count (:ices run)) (:position run))
                                (:rezzed (get-in (:ices (card->server state card)) [(:position run)]))))
                 :effect (req (let [icename (:title (get-in (:ices (card->server state card)) [(:position run)]))]
                                (resolve-ability
                                  state side
                                  {:prompt "Choose a copy of the ICE just passed"
                                   :choices {:req #(and (= (:zone %) [:hand])
                                                        (= (:type %) "ICE")
                                                        (= (:title %) icename))}
                                   :effect (req (trash state side (assoc target :seen true))
                                                (swap! state update-in [:run]
                                                       #(assoc % :position (inc (:position run)))))
                                   :msg (msg "trash a copy of " (:title target) " from HQ and force the Runner to encounter it again")}
                                 card nil)))}]}

   "Tyrs Hand"
   {:abilities [{:label "[Trash]: Prevent a subroutine on a Bioroid from being broken"
                 :req (req (and (= (butlast (:zone current-ice)) (butlast (:zone card)))
                                (has? current-ice :subtype "Bioroid"))) :effect (effect (trash card))
                 :msg (msg "prevent a subroutine on " (:title current-ice) " from being broken")}]}

   "Will-o-the-Wisp"
   {:abilities [{:label "[Trash]: Add an icebreaker to the bottom of Stack"
                 :choices {:req #(has? % :subtype "Icebreaker")}
                 :msg (msg "add " (:title target) " to the bottom of Stack")
                 :effect (effect (trash card) (move :runner target :deck))}]}})

(in-ns 'game.core)

(def cards-upgrades
  {"Akitaro Watanabe"
   {:events {:pre-rez-cost {:req (req (and (= (:type target) "ICE")
                                           (= (card->server state card) (card->server state target))))
                            :effect (effect (rez-cost-bonus -2))}}}

   "Amazon Industrial Zone"
   {:events
     {:corp-install  {:optional {:req (req (and (= (:type target) "ICE")
                                                (= (card->server state card) (card->server state target))))
                                 :prompt "Rez ICE with rez cost lowered by 3?"
                                 :yes-ability {:effect (effect (rez-cost-bonus -3) (rez target))}}}}}

   "Ash 2X3ZB9CY"
   {:abilities [{:label "Trace 4 - Prevent the Runner from accessing cards other than Ash 2X3ZB9CY"
                 :trace {:base 4
                         :effect (req (max-access state side 0)
                                      (let [ash card]
                                        (swap! state update-in [:run :run-effect]
                                               #(assoc % :successful-run
                                                         {:effect (effect (handle-access [ash])) :card ash}))))
                         :msg "prevent the Runner from accessing cards other than Ash 2X3ZB9CY"}}]}

   "Awakening Center"
   {:abilities [{:label "Host a piece of bioroid ICE"
                 :cost [:click 1] :prompt "Choose a piece of bioroid ICE to host on Awakening Center"
                 :choices (req (filter #(and (= (:type %) "ICE")
                                             (has? % :subtype "Bioroid")) (:hand corp)))
                 :msg "host a piece of bioroid ICE"
                 :effect (effect (trigger-event :corp-install target)
                                 (host card target {:facedown true}))}
                {:req (req (and this-server (= (get-in @state [:run :position]) 0)))
                 :label "Rez a hosted piece of bioroid ICE"
                 :prompt "Choose a piece of bioroid ICE to rez" :choices (req (:hosted card))
                 :msg (msg "lower the rez cost of " (:title target) " by 7 [Credits] and force the Runner to encounter it")
                 :effect (effect (rez-cost-bonus -7) (rez target)
                                 (update! (dissoc (get-card state target) :facedown))
                                 (register-events {:run-ends
                                                    {:effect (req (doseq [c (:hosted card)]
                                                                    (when (:rezzed c)
                                                                      (trash state side c)))
                                                                  (unregister-events state side card))}} card))}]
    :events {:run-ends nil}}

   "Bernice Mai"
   {:events {:successful-run {:req (req this-server)
                              :trace {:base 5 :msg "give the Runner 1 tag"
                                      :effect (effect (tag-runner :runner 1))}}}}

   "Breaker Bay Grid"
   {:events {:pre-rez-cost {:req (req (= (:zone card) (:zone target)))
                            :effect (effect (rez-cost-bonus -5))}}}

   "Caprice Nisei"
   {:abilities [{:msg "start a Psi game"
                 :psi {:not-equal {:msg "end the run" :effect (effect (end-run))}}}]}

   "ChiLo City Grid"
   {:events {:successful-trace {:req (req this-server)
                                :effect (effect (tag-runner :runner 1))
                                :msg "give the Runner 1 tag"}}}

   "Corporate Troubleshooter"
   {:abilities [{:label "[Trash]: Add strength to a rezzed ICE protecting this server" :choices :credit
                 :prompt "How many credits?"
                 :effect (req (let [boost target]
                                (resolve-ability
                                  state side
                                  {:choices {:req #(and (has? % :type "ICE") (:rezzed %))}
                                   :msg (msg "add " boost " strength to " (:title target))
                                   :effect (req (update! state side (assoc card :troubleshooter-target target
                                                                                :troubleshooter-amount boost))
                                                (trash state side (get-card state card))
                                                (update-ice-strength state side target))} card nil)))}]
    :events {:pre-ice-strength nil :runner-turn-ends nil :corp-turn-ends nil}
    :trash-effect
               {:effect (req (register-events
                               state side
                               (let [ct {:effect (req (unregister-events state side card)
                                                      (update! state side (dissoc card :troubleshooter-target))
                                                      (update-ice-strength state side (:troubleshooter-target card)))}]
                                 {:pre-ice-strength
                                                    {:req (req (= (:cid target) (:cid (:troubleshooter-target card))))
                                                     :effect (effect (ice-strength-bonus (:troubleshooter-amount card)))}
                                  :runner-turn-ends ct :corp-turn-ends ct}) card))}}

   "Crisium Grid"
   {:suppress {:successful-run {:req (req (and this-server (not= (:cid target) (:cid card))))}}
    :events {:successful-run {:req (req this-server)
                              :effect (req (swap! state update-in [:run :run-effect] dissoc :replace-access)
                                           (swap! state update-in [:run] dissoc :successful)
                                           (swap! state update-in [:runner :register :successful-run] #(butlast %)))}}}

   "Cyberdex Virus Suite"
   {:access {:optional {:prompt "Purge viruses with Cyberdex Virus Suite?"
                        :yes-ability {:msg (msg "purge viruses")
                                      :effect (effect (purge))}}}
    :abilities [{:label "[Trash]: Purge virus counters"
                 :msg "purge viruses" :effect (effect (purge) (trash card))}]}

   "Dedicated Technician Team"
   {:recurring 2}

   "Experiential Data"
   {:effect (req (update-ice-in-server state side (card->server state card)))
    :events {:pre-ice-strength {:req (req (= (card->server state card) (card->server state target)))
                                :effect (effect (ice-strength-bonus 1))}}
    :derez-effect {:effect (req (update-ice-in-server state side (card->server state card)))}
    :trash-effect {:effect (req (update-all-ice state side))}}

   "Expo Grid"
   {:events {:corp-turn-begins {:req (req (not (empty? (filter #(and (= (:type %) "Asset") (:rezzed %))
                                                               (get-in corp (:zone card))))))
                                :msg "gain 1 [Credits]" :effect (effect (gain :credit 1))}}}

   "Heinlein Grid"
   {:effect (req (add-watch state (keyword (str "heinlein" (:cid card)))
                   (fn [k ref old new]
                     (let [clicknew (get-in new [:runner :click])
                           clickold (get-in old [:runner :click])]
                       (when (< clicknew clickold)
                         (resolve-ability ref side
                           {:req (req this-server)
                            :msg (msg "force the Runner to lose all " (:credit runner) " [Credits]") :once :per-run
                            :effect (effect (lose :runner :credit :all))}
                          card nil))))))
    :leave-play (req (remove-watch state (keyword (str "heinlein" (:cid card)))))}

   "Hokusai Grid"
   {:events {:successful-run {:req (req this-server) :msg "do 1 net damage"
                              :effect (req (damage state side :net 1 {:card card}))}}}

   "Keegan Lane"
   {:abilities [{:label "[Trash], remove a tag: Trash a program"
                 :req (req (and this-server
                                (> (get-in @state [:runner :tag]) 0)
                                (not (empty? (filter #(has? % :type "Program") (all-installed state :runner))))))
                 :msg (msg "remove 1 tag")
                 :effect (req (resolve-ability state side trash-program card nil)
                              (trash state side card {:cause :ability-cost})
                              (lose state :runner :tag 1))}]}

   "Marcus Batty"
   {:abilities [{:req (req this-server)
                 :label "[Trash]: Start a Psi game" :msg "start a Psi game"
                 :psi {:not-equal {:prompt "Choose a rezzed piece of ICE to resolve one of its subroutines"
                                   :choices {:req #(and (has? % :type "ICE")
                                                        (:rezzed %))}
                                   :msg (msg "resolve a subroutine on " (:title target))}}
                 :effect (effect (trash card))}]}

   "Midori"
   {:abilities
    [{:req (req this-server)
      :label "Swap the ICE being approached with a piece of ICE from HQ"
      :prompt "Choose a piece of ICE" :choices (req (filter #(has? % :type "ICE") (:hand corp))) :once :per-run
      :msg (msg "swap " (if (:rezzed current-ice) (:title current-ice) "the approached ICE") " with a piece of ICE from HQ")
      :effect (req (let [hqice target
                         c current-ice]
                     (resolve-ability state side
                       {:effect (req (let [newice (assoc hqice :zone (:zone c))
                                           cndx (ice-index state c)
                                           ices (get-in @state (cons :corp (:zone c)))
                                           newices (apply conj (subvec ices 0 cndx) newice (subvec ices cndx))]
                                       (swap! state assoc-in (cons :corp (:zone c)) newices)
                                       (swap! state update-in [:corp :hand]
                                              (fn [coll] (remove-once #(not= (:cid %) (:cid hqice)) coll)))
                                       (trigger-event state side :corp-install newice)
                                       (move state side c :hand)
                                       (update-run-ice state side)))} card nil)))}]}

   "NeoTokyo Grid"
   {:events {:advance {:req (req (= (butlast (:zone target)) (butlast (:zone card)))) :once :per-turn
                       :msg "gain 1 [Credits]" :effect (effect (gain :credit 1))}}}

   "Oaktown Grid"
   {:events {:pre-trash {:req (req (= (:zone card) (:zone target)))
                         :effect (effect (trash-cost-bonus 3))}}}

   "Off the Grid"
   {:events {:successful-run {:req (req (= target :hq))
                              :effect (req (trash state :corp card)
                                           (system-msg state :corp (str "trashes Off the Grid")))}}}

   "Old Hollywood Grid"
   (let [ab {:req (req (or (= (:zone card) (:zone target)) (= (central->zone (:zone target)) (butlast (:zone card)))))
             :effect (req (if (not (some #(= (:title %) (:title target)) (:scored runner)))
                            (prevent-steal state side)
                            (swap! state update-in [:runner :register] dissoc :cannot-steal)))}
         un {:effect (req (swap! state update-in [:runner :register] dissoc :cannot-steal))}]
     {:trash-effect
      {:req (req (= :servers (first (:previous-zone card))))
       :effect (effect (register-events {:pre-steal-cost (assoc ab :req (req (= (:zone target)
                                                                                (:previous-zone card))))
                                         :run-ends {:effect (req (unregister-events state side card)
                                                                 (swap! state update-in [:runner :register] dissoc
                                                                        :cannot-steal))}}
                                        (assoc card :zone '(:discard))))}
      :events {:pre-steal-cost ab :run-ends un}})

   "Panic Button"
   {:init {:root "HQ"} :abilities [{:cost [:credit 1] :effect (effect (draw))
                                    :req (req (and run (= (first (:server run)) :hq)))}]}

   "Product Placement"
   {:access {:req (req (not= (first (:zone card)) :discard))
             :msg "gain 2 [Credits]" :effect (effect (gain :corp :credit 2))}}

   "Red Herrings"
   (let [ab {:req (req (= (:zone card) (:zone target)))
             :effect (effect (steal-cost-bonus [:credit 5]))}]
     {:trash-effect {:req (req (= :servers (first (:previous-zone card))))
                     :effect (effect (register-events {:pre-steal-cost (assoc ab :req (req (= (:zone target)
                                                                                (:previous-zone card))))
                                                       :run-ends {:effect (effect (unregister-events card))}}
                                                      (assoc card :zone '(:discard))))}
      :events {:pre-steal-cost ab :run-ends nil}})

   "Research Station"
   {:init {:root "HQ"}
    :effect (effect (gain :max-hand-size 2)) :leave-play (effect (lose :max-hand-size 2))}

   "Rutherford Grid"
   {:events {:pre-init-trace {:req (req this-server)
                              :effect (effect (init-trace-bonus 2))}}}

   "Ryon Knight"
   {:abilities [{:label "[Trash]: Do 1 brain damage"
                 :msg "do 1 brain damage" :req (req (and this-server (zero? (:click runner))))
                 :effect (effect (trash card) (damage :brain 1 {:card card}))}]}

   "SanSan City Grid"
   {:effect (req (when-let [agenda (some #(when (= (:type %) "Agenda") %) (:content (card->server state card)))]
                   (update-advancement-cost state side agenda)))
    :events {:corp-install {:req (req (and (= (:type target) "Agenda") (= (:zone card) (:zone target))))
                            :effect (effect (update-advancement-cost target))}
             :pre-advancement-cost {:req (req (= (:zone card) (:zone target)))
                                    :effect (effect (advancement-cost-bonus -1))}}}

   "Self-destruct"
   {:abilities [{:req (req this-server)
                 :label "[Trash]: Trace X - Do 3 net damage"
                 :effect (req (let [serv (card->server state card)
                                    cards (concat (:ices serv) (:content serv))]
                                (trash state side card)
                                (doseq [c cards] (trash state side c))
                                (resolve-ability
                                  state side
                                  {:trace {:base (req (dec (count cards)))
                                           :effect (effect (damage :net 3 {:card card}))
                                           :msg "do 3 net damage"}} card nil)))}]}

   "Shell Corporation"
   {:abilities
    [{:cost [:click 1] :msg "store 3 [Credits]" :once :per-turn
      :effect (effect (add-prop card :counter 3))}
     {:cost [:click 1] :msg (msg "gain " (:counter card) " [Credits]") :once :per-turn
      :label "Take all credits"
      :effect (effect (gain :credit (:counter card)) (set-prop card :counter 0))}]}

   "Simone Diego"
   {:recurring 2}

   "Strongbox"
   (let [ab {:req (req (= (:zone card) (:zone target)))
             :effect (effect (steal-cost-bonus [:click 1]))}]
     {:trash-effect {:req (req (= :servers (first (:previous-zone card))))
                     :effect (effect (register-events {:pre-steal-cost (assoc ab :req (req (= (:zone target)
                                                                                (:previous-zone card))))
                                                       :run-ends {:effect (effect (unregister-events card))}}
                                                      (assoc card :zone '(:discard))))}
      :events {:pre-steal-cost ab :run-ends nil}})

   "The Twins"
   {:abilities [{:label "Reveal and trash a copy of the ICE just passed from HQ"
                 :req (req (and this-server
                                (> (count (:ices run)) (:position run))
                                (:rezzed (get-in (:ices (card->server state card)) [(:position run)]))))
                 :effect (req (let [icename (:title (get-in (:ices (card->server state card)) [(:position run)]))]
                                (resolve-ability
                                  state side
                                  {:prompt "Choose a copy of the ICE just passed"
                                   :choices {:req #(and (= (:zone %) [:hand])
                                                        (= (:type %) "ICE")
                                                        (= (:title %) icename))}
                                   :effect (req (trash state side (assoc target :seen true))
                                                (swap! state update-in [:run]
                                                       #(assoc % :position (inc (:position run)))))
                                   :msg (msg "trash a copy of " (:title target) " from HQ and force the Runner to encounter it again")}
                                 card nil)))}]}

   "Tyrs Hand"
   {:abilities [{:label "[Trash]: Prevent a subroutine on a Bioroid from being broken"
                 :req (req (and (= (butlast (:zone current-ice)) (butlast (:zone card)))
                                (has? current-ice :subtype "Bioroid"))) :effect (effect (trash card))
                 :msg (msg "prevent a subroutine on " (:title current-ice) " from being broken")}]}

   "Will-o-the-Wisp"
   {:abilities [{:label "[Trash]: Add an icebreaker to the bottom of Stack"
                 :choices {:req #(has? % :subtype "Icebreaker")}
                 :msg (msg "add " (:title target) " to the bottom of Stack")
                 :effect (effect (trash card) (move :runner target :deck))}]}})

fix Marcus Batty to trash itself properly and do the ice targeting


;;; Interpreters using the memory subsystem

;;; This file contains experimental interpreters that use the memory
;;; subsystem.  I write these interpreters to try the memory subsystem
;;; in a more realistic context than the unit tests.

;;; Currently I'm thinking of implementing a simple
;;; continuation-passing interpreter (that, obviously, also has to be
;;; a storage-passing interpreter).  I'm not sure whether to implement
;;; mutable variables in this interpreter, since this would mean that
;;; all parameters have to be boxed and passed on the heap.  And since
;;; we never release storage on the heap this would probably
;;; prohibitively wasteful.  In a compiler we can avoid this by
;;; performing a closure analysis pass.  Of course, the "interpreters"
;;; could also use a preprocessing pass that performs these kinds of
;;; analysis, but then the interpreters would mutate into compilers
;;; with a different IR.  That's not really the current plan, but
;;; we'll see how things work out.  --tc

(ns revue.interpreter
  (:require [revue.util :as util]
            [revue.mem :as mem]))

;;; Utilities
;;; =========

(defn warn
  "Warn about a problem encountered by an interpreter."
  [msg]
  (util/warn "Interpreter warning:" msg))

;;; Environments for the interpreter
;;; ================================

;;; The interpreters use a simple Clojure map as environment.

;;; We define function to create and update the global environment
;;; which are used to initialize the interpreter.  The interpreter
;;; only uses one non-standard function for manipulating environment:
;;; `extend-env' is called when a new lexical scope is entered and
;;; returns the previous environment extended with the new bindings.
;;; To update the environment we simply use `assoc', to look up values
;;; we use `get'.

(defn empty-env
  "Returns an empty environment."
  []
  {})

(def ^:dynamic *initial-bindings* (atom {}))

(defn clear-initial-bindings
  "Set the value of `*initial-bindings*' to the empty map."
  []
  (reset! *initial-bindings* {}))

(defn define-global
  "Defines a global variable, or redefines it if it already exists"
  [name value]
  (swap! *initial-bindings* assoc name value))

(defn global-env
  "Returns the global environment for the interpreter."
  []
  @*initial-bindings*)

(defn extend-env [env keys values]
  (merge env (zipmap keys values)))

;;; Procedures for the interpreter
;;; ===============================

;;; We define a protocol IProc that specifies how the interpreter
;;; handles procedures, and record types for representing interpreted
;;; procedures as well as primitive procedures.

(defprotocol IProc
  "Procedures that can be invoked by the interpreter"
  (apply-proc [this args state]
    "Apply the procedure to `args' and `state', and return a new
    state"))

;;; An interpreted procedure.  Its `code' is the source code to be
;;; interpreted; `params' is a list of parameter names; `name' is the
;;; name of the procedure (as clojure symbol), or `nil' if the
;;; procedure is anonymous.
;;;
(defrecord Proc [code env params name]
  IProc
  (apply-proc [this args state]
    (assoc state
      :form (:code this)
      :env (extend-env (:env this) (:params this) args)
      :cont `((::return-from-call ~(:env state)) ~@(:cont state))))
  mem/StoredData
  (-->clojure [this store]
    this))

;;; A primitive procedure.  Its `code' is a Clojure function that
;;; should be invoked.  The `params' and `name' fields are as for
;;; `Proc'
;;;
(defrecord Prim [code params name]
  IProc
  (apply-proc [this args state]
    ((:code this) args state))
  mem/StoredData
  (-->clojure [this store]
    this))

(defn define-nary-global [name fun]
  (define-global name
    (->Prim (fn [args state]
              (assoc state :form nil :value (apply fun args)))
            '[& args]
            name)))

(defn define-binary-global [name fun]
  (define-global name
    (->Prim (fn [args state]
              (assoc state :form nil :value (apply fun args)))
            '[x y]
            name)))

(define-nary-global '+ +)
(define-nary-global '- -)
(define-nary-global '* *)
(define-nary-global '/ /)

(define-binary-global '< <)
(define-binary-global '> >)
(define-binary-global '<= <=)
(define-binary-global '>= >=)

(define-nary-global 'print print)
(define-nary-global 'println println)

;;; A simple state-passing interpreter
;;; ==================================

;;; The core of the simple interpreter is a function `step' that
;;; performs one step of the evaluation process.  It operates on an
;;; iterpreter state that contains all information required by the
;;; interpreter; i.e., its sole argument is an interpreter state and
;;; its result is again an interpreter state.

;;; The state contains the following elements:
;;; * the form to be executed
;;; * the environment for the form
;;; * the store
;;; * a continuation
;;; * The value returned by the previous evaluation step

;;; Not sure whether that is a good idea, since we want to share as
;;; much data as possible, and introducing a record will probably
;;; store each state in a fresh object.
;;; TODO: check this
;;;
#_(defrecord State [form env store cont value])

(defn initial-store []
  [])

(defn initial-state
  "Create an initial state for the interpreter"
  ([& forms]
     {:form (util/maybe-add 'begin forms)
      :env (global-env) :store (initial-store)
      :cont nil :value nil}))

;;; TODO: Refactor this into multi-methods

;;; TODO: Should we clear the :value field for forms which have no
;;; return value on their own?

(defn step
  "Perform a single step of the interpreter and return a new state"
  [{:keys [form env store cont value] :as state}]
  (cond
   ;;
   (nil? form)
   (if cont
     (assoc state :form (first cont) :cont (next cont))
     (assoc state :value nil))
   ;;
   (symbol? form)
   (assoc state :form nil :value (mem/->clojure (get env form) store))
   ;;
   (util/atomic? form)
   (assoc state :form nil :value form)
   ;; TODO: integrate macros here...
   ;;
   :else
   (case (first form)
     ;; Quote
     quote
     (assoc state :form nil :value (rest form))
     ;; Definitions
     define
     (let [[box new-store] (mem/new-box nil store)]
       (assoc state
         :form (nth form 2)
         :env (assoc env (nth form 1) box)
         :store new-store
         :cont `((::define ~box) ~@cont)))
     ::define
     (assoc state
       :form nil
       :store (mem/box-set! value (nth form 1) store))
     ;; Sequence
     begin
     (cond
      ;; An empty begin evaluates to false.
      (empty? (rest form))
      (assoc state :form nil :value false)
      ;; A begin containing a single form is equivalent to that form.
      (util/singleton? (rest form))
      (assoc state :form (nth form 1))
      :else
      ;; We have a begin with at least two subforms.  Extract the
      ;; first subform, push the remaining forms onto the
      ;; continuation.
      (assoc state
        :form (nth form 1)
        :cont (cons (cons 'begin (nthrest form 2)) cont)))
     ;; If: Compute the condition and add a continuation that uses
     ;; this value to choose the correct branch.
     if
     (assoc state
       :form (nth form 1)
       :cont (cons (cons ::if (nthrest form 2)) cont))
     ;; The continuation function for the `if' operator
     ::if
     (assoc state
       :form (if (mem/->clojure value store)
               (nth form 1)
               (nth form 2)))
     ;; Function definition
     lambda
     (assoc state
       :form nil
       :value (->Proc (util/maybe-add 'begin (nthrest form 2))
                      env
                      (vec (nth form 1))
                      nil))
     ;; If we arrive here, we have a function application.  First we
     ;; need to pick off the continuation functons for function
     ;; applications, though.
     ::eval-args
     (if (empty? (nthrest form 2)) ;; TODO: Check that new form evaluates function?
       (assoc state
         :form (first cont)
         :cont (next cont)
         :value (nth form 1))
       (assoc state
         :form (nth form 2)
         :cont `((::collect-arg ~(nth form 1) ~@(nthrest form 3)) ~@cont)))
     ::collect-arg
     (assoc state
       :form `(::eval-args ~(conj (nth form 1) value)
                           ~@(nthrest form 2)))
     ::eval-proc
     (assoc state
       :form (nth form 1)
       :cont `((::apply ~value) ~@cont))
     ::apply
     ;; TODO: Need to handle primitive procedures; define protocol for
     ;; application
     (let [proc value
           [_ args] form]
       (apply-proc proc args state))
     ::return-from-call
     (assoc state
       :form nil
       :env (nth form 1))
     (let [[proc & args] form]
       (assoc state
         :form `(::eval-args [] ~@args)
         :cont `((::eval-proc ~proc) ~@cont)
         :value [])))))

(def ^:dynamic *run-n-steps* (atom 100))

(defn run-n-steps
  ([& forms]
     (let [result (take @*run-n-steps*
                        (take-while
                         (fn [{:keys [form cont value]}] (or form cont value))
                         (iterate step (apply initial-state forms))))]
       (clojure.pprint/pprint result)
       (last result))))

(def ^:dynamic *interp-steps* (atom 100000))

(defn interp
  ([& forms]
     (let [result (take @*interp-steps*
                        (take-while
                         (fn [{:keys [form cont value]}] (or form cont value))
                         (iterate step (apply initial-state forms))))]
       result)))

;;; Functions for cleaning up the interpreter trace
;;; ===============================================

(defn recursively-remove-global-vars-in [d]
  (cond
   (map? d)
   (into {}
         (map (fn [[k v]]
                (if (= k :env)
                  (let [genv (global-env)]
                    [k (into {} (keep (fn [[k1 v1]]
                                        (if (contains? genv k1)
                                          nil
                                          [k1 (recursively-remove-global-vars-in v1)]))
                                      v))])
                  [k (recursively-remove-global-vars-in v)]))
              d))
   (or (sequential? d))
   (if (= (first d) ::return-from-call)
     ::return-from-call
     (map recursively-remove-global-vars-in d))
   :else
   d))

(defn remove-global-vars
  "Removes all values from environments in a seq of states that are
  defined in the global environment.  Does not take into account redefinitions!"
  [states]
  (map recursively-remove-global-vars-in states))

(def *internal-ops* #{::eval-args ::collect-arg ::eval-proc})

(defn remove-internal-forms
  "Removes all forms that don't evaluate user code."
  [states]
  (keep (fn [{:keys [form] :as state}]
          (if (or (nil? form)
                  (and (sequential? form) (contains? *internal-ops* (first form))))
            nil
            state))
        states))

(defn remove-continuations
  "Removes all continuations from states."
  [states]
  (map #(dissoc %1 :cont) states))

(def cleanup-trace (comp remove-global-vars remove-internal-forms remove-continuations))

;;; Try the following examples:
(comment
  (:value (last (interp '(+ 1 2))))
  (clojure.pprint/pprint
   (cleanup-trace
    (interp '((lambda (f n) (if (<= n 1) n (* n (f f (- n 1)))))
              (lambda (f n) (if (<= n 1) n (* n (f f (- n 1))))) 3))))
  (:value (last (interp '((lambda (f n) (if (<= n 1) n (* n (f f (- n 1)))))
                          (lambda (f n) (if (<= n 1) n (* n (f f (- n 1))))) 10))))
  (:value (last (interp '((lambda (f n) (if (<= n 1) n (* n (f f (- n 1)))))
                          (lambda (f n) (if (<= n 1) n (* n (f f (- n 1))))) 1000N))))
  (:value (last (interp '(define x (+ 1 2))
                        '(println x)
                        '((lambda () (define x 2) (println x)))
                        '(println x)
                        'x)))
  (:value (last (interp '(define f (lambda (n) n))
                        '(f 1))))
  (:value (last (interp '(define f (lambda (n) (if (>= n 1) f 1)))
                        '(f 1))))
  (clojure.pprint/pprint
   (cleanup-trace
    (interp '(define fact (lambda (n) (if (<= n 1) 1 (* (fact (- n 1)) n))))
            '(fact 4))))
  (:value (last (interp '(define fact (lambda (n) (if (<= n 1) 1 (* (fact (- n 1)) n))))
                        '(fact 4))))
  (:value (last (interp '(define fact (lambda (n) (if (<= n 1) 1 (* (fact (- n 1)) n))))
                        '(fact 1000N))))
  )

;;; Evaluate this (e.g., with C-x C-e in Cider) to run the tests for
;;; this namespace:
;;; (clojure.test/run-tests 'revue.interpreter-test)
;;; Evaluate this to run the test for all namespaces:
;;; (clojure.test/run-all-tests #"^revue\..*-test")

;;; Interpreters using the memory subsystem

;;; This file contains experimental interpreters that use the memory
;;; subsystem.  I write these interpreters to try the memory subsystem
;;; in a more realistic context than the unit tests.

;;; Currently I'm thinking of implementing a simple
;;; continuation-passing interpreter (that, obviously, also has to be
;;; a storage-passing interpreter).  I'm not sure whether to implement
;;; mutable variables in this interpreter, since this would mean that
;;; all parameters have to be boxed and passed on the heap.  And since
;;; we never release storage on the heap this would probably
;;; prohibitively wasteful.  In a compiler we can avoid this by
;;; performing a closure analysis pass.  Of course, the "interpreters"
;;; could also use a preprocessing pass that performs these kinds of
;;; analysis, but then the interpreters would mutate into compilers
;;; with a different IR.  That's not really the current plan, but
;;; we'll see how things work out.  --tc

(ns revue.interpreter
  (:require [revue.util :as util]
            [revue.mem :as mem]))

;;; Utilities
;;; =========

(defn warn
  "Warn about a problem encountered by an interpreter."
  [msg]
  (util/warn "Interpreter warning:" msg))

;;; Environments for the interpreter
;;; ================================

;;; The interpreters use a simple Clojure map as environment.

;;; We define function to create and update the global environment
;;; which are used to initialize the interpreter.  The interpreter
;;; only uses one non-standard function for manipulating environment:
;;; `extend-env' is called when a new lexical scope is entered and
;;; returns the previous environment extended with the new bindings.
;;; To update the environment we simply use `assoc', to look up values
;;; we use `get'.

(defn empty-env
  "Returns an empty environment."
  []
  {})

(def ^:dynamic *initial-bindings* (atom {}))

(defn clear-initial-bindings
  "Set the value of `*initial-bindings*' to the empty map."
  []
  (reset! *initial-bindings* {}))

(defn define-global
  "Defines a global variable, or redefines it if it already exists"
  [name value]
  (swap! *initial-bindings* assoc name value))

(defn global-env
  "Returns the global environment for the interpreter."
  []
  @*initial-bindings*)

(defn extend-env [env keys values]
  (merge env (zipmap keys values)))

;;; Procedures for the interpreter
;;; ===============================

;;; We define a protocol IProc that specifies how the interpreter
;;; handles procedures, and record types for representing interpreted
;;; procedures as well as primitive procedures.

(defprotocol IProc
  "Procedures that can be invoked by the interpreter"
  (apply-proc [this args state]
    "Apply the procedure to `args' and `state', and return a new
    state"))

;;; An interpreted procedure.  Its `code' is the source code to be
;;; interpreted; `params' is a list of parameter names; `name' is the
;;; name of the procedure (as clojure symbol), or `nil' if the
;;; procedure is anonymous.
;;;
(defrecord Proc [code env params name]
  IProc
  (apply-proc [this args state]
    (assoc state
      :form (:code this)
      :env (extend-env (:env this) (:params this) args)
      :cont `((::return-from-call ~(:env state)) ~@(:cont state))))
  mem/StoredData
  (-->clojure [this store]
    this))

;;; A primitive procedure.  Its `code' is a Clojure function that
;;; should be invoked.  The `params' and `name' fields are as for
;;; `Proc'
;;;
(defrecord Prim [code params name]
  IProc
  (apply-proc [this args state]
    ((:code this) args state))
  mem/StoredData
  (-->clojure [this store]
    this))

(defn define-nary-global [name fun]
  (define-global name
    (->Prim (fn [args state]
              (assoc state :form nil :value (apply fun args)))
            '[& args]
            name)))

(defn define-binary-global [name fun]
  (define-global name
    (->Prim (fn [args state]
              (assoc state :form nil :value (apply fun args)))
            '[x y]
            name)))

(define-nary-global '+ +)
(define-nary-global '- -)
(define-nary-global '* *)
(define-nary-global '/ /)

(define-binary-global '< <)
(define-binary-global '> >)
(define-binary-global '<= <=)
(define-binary-global '>= >=)

(define-nary-global 'print print)
(define-nary-global 'println println)

;;; A simple state-passing interpreter
;;; ==================================

;;; The core of the simple interpreter is a function `step' that
;;; performs one step of the evaluation process.  It operates on an
;;; iterpreter state that contains all information required by the
;;; interpreter; i.e., its sole argument is an interpreter state and
;;; its result is again an interpreter state.

;;; The state contains the following elements:
;;; * the form to be executed
;;; * the environment for the form
;;; * the store
;;; * a continuation
;;; * The value returned by the previous evaluation step

;;; Not sure whether that is a good idea, since we want to share as
;;; much data as possible, and introducing a record will probably
;;; store each state in a fresh object.
;;; TODO: check this
;;;
#_(defrecord State [form env store cont value])

(defn initial-store []
  [])

(defn initial-state
  "Create an initial state for the interpreter"
  ([& forms]
     {:form (util/maybe-add 'begin forms)
      :env (global-env) :store (initial-store)
      :cont nil :value nil}))

;;; TODO: Refactor this into multi-methods

;;; TODO: Should we clear the :value field for forms which have no
;;; return value on their own?

(defn step
  "Perform a single step of the interpreter and return a new state"
  [{:keys [form env store cont value] :as state}]
  (cond
   ;;
   (nil? form)
   (if cont
     (assoc state :form (first cont) :cont (next cont))
     (assoc state :value nil))
   ;;
   (symbol? form)
   (assoc state :form nil :value (mem/->clojure (get env form) store))
   ;;
   (util/atomic? form)
   (assoc state :form nil :value form)
   ;; TODO: integrate macros here...
   ;;
   :else
   (case (first form)
     ;; Quote
     quote
     (assoc state :form nil :value (rest form))
     ;; Definitions
     define
     (let [[box new-store] (mem/new-box nil store)
           name (nth form 1)]
       (assoc state
         :form (nth form 2)
         :env (assoc env name box)
         :store new-store
         :cont `((::define ~name ~box) ~@cont)))
     ::define
     (assoc state
       :form nil
       :store (mem/box-set! (if (instance? Proc value)
                              (assoc value :name (nth form 1))
                              value) (nth form 2) store))
     ;; Sequence
     begin
     (cond
      ;; An empty begin evaluates to false.
      (empty? (rest form))
      (assoc state :form nil :value false)
      ;; A begin containing a single form is equivalent to that form.
      (util/singleton? (rest form))
      (assoc state :form (nth form 1))
      :else
      ;; We have a begin with at least two subforms.  Extract the
      ;; first subform, push the remaining forms onto the
      ;; continuation.
      (assoc state
        :form (nth form 1)
        :cont (cons (cons 'begin (nthrest form 2)) cont)))
     ;; If: Compute the condition and add a continuation that uses
     ;; this value to choose the correct branch.
     if
     (assoc state
       :form (nth form 1)
       :cont (cons (cons ::if (nthrest form 2)) cont))
     ;; The continuation function for the `if' operator
     ::if
     (assoc state
       :form (if (mem/->clojure value store)
               (nth form 1)
               (nth form 2)))
     ;; Function definition
     lambda
     (assoc state
       :form nil
       :value (->Proc (util/maybe-add 'begin (nthrest form 2))
                      env
                      (vec (nth form 1))
                      nil))
     ;; If we arrive here, we have a function application.  First we
     ;; need to pick off the continuation functons for function
     ;; applications, though.
     ::eval-args
     (if (empty? (nthrest form 2)) ;; TODO: Check that new form evaluates function?
       (assoc state
         :form (first cont)
         :cont (next cont)
         :value (nth form 1))
       (assoc state
         :form (nth form 2)
         :cont `((::collect-arg ~(nth form 1) ~@(nthrest form 3)) ~@cont)))
     ::collect-arg
     (assoc state
       :form `(::eval-args ~(conj (nth form 1) value)
                           ~@(nthrest form 2)))
     ::eval-proc
     (assoc state
       :form (nth form 1)
       :cont `((::apply ~value) ~@cont))
     ::apply
     ;; TODO: Need to handle primitive procedures; define protocol for
     ;; application
     (let [proc value
           [_ args] form]
       (apply-proc proc args state))
     ::return-from-call
     (assoc state
       :form nil
       :env (nth form 1))
     (let [[proc & args] form]
       (assoc state
         :form `(::eval-args [] ~@args)
         :cont `((::eval-proc ~proc) ~@cont)
         :value [])))))

(def ^:dynamic *run-n-steps* (atom 100))

(defn run-n-steps
  ([& forms]
     (let [result (take @*run-n-steps*
                        (take-while
                         (fn [{:keys [form cont value]}] (or form cont value))
                         (iterate step (apply initial-state forms))))]
       (clojure.pprint/pprint result)
       (last result))))

(def ^:dynamic *interp-steps* (atom 100000))

(defn interp
  ([& forms]
     (let [result (take @*interp-steps*
                        (take-while
                         (fn [{:keys [form cont value]}] (or form cont value))
                         (iterate step (apply initial-state forms))))]
       result)))

;;; Functions for cleaning up the interpreter trace
;;; ===============================================

(defn recursively-remove-global-vars-in [d]
  (cond
   (map? d)
   (into {}
         (map (fn [[k v]]
                (if (= k :env)
                  (let [genv (global-env)]
                    [k (into {} (keep (fn [[k1 v1]]
                                        (if (contains? genv k1)
                                          nil
                                          [k1 (recursively-remove-global-vars-in v1)]))
                                      v))])
                  [k (recursively-remove-global-vars-in v)]))
              d))
   (or (sequential? d))
   (if (= (first d) ::return-from-call)
     ::return-from-call
     (map recursively-remove-global-vars-in d))
   :else
   d))

(defn remove-global-vars
  "Removes all values from environments in a seq of states that are
  defined in the global environment.  Does not take into account redefinitions!"
  [states]
  (map recursively-remove-global-vars-in states))

(def ^:dynamic *internal-ops* #{::eval-args ::collect-arg ::eval-proc})

(defn remove-internal-forms
  "Removes all forms that don't evaluate user code."
  [states]
  (keep (fn [{:keys [form] :as state}]
          (if (or (nil? form)
                  (and (sequential? form) (contains? *internal-ops* (first form))))
            nil
            state))
        states))

(defn remove-continuations
  "Removes all continuations from states."
  [states]
  (map #(dissoc %1 :cont) states))

(def cleanup-trace (comp remove-global-vars remove-internal-forms remove-continuations))

;;; Try the following examples:
(comment
  (:value (last (interp '(+ 1 2))))
  (clojure.pprint/pprint
   (cleanup-trace
    (interp '((lambda (f n) (if (<= n 1) n (* n (f f (- n 1)))))
              (lambda (f n) (if (<= n 1) n (* n (f f (- n 1))))) 3))))
  (:value (last (interp '((lambda (f n) (if (<= n 1) n (* n (f f (- n 1)))))
                          (lambda (f n) (if (<= n 1) n (* n (f f (- n 1))))) 10))))
  (:value (last (interp '((lambda (f n) (if (<= n 1) n (* n (f f (- n 1)))))
                          (lambda (f n) (if (<= n 1) n (* n (f f (- n 1))))) 1000N))))
  (:value (last (interp '(define x (+ 1 2))
                        '(println x)
                        '((lambda () (define x 2) (println x)))
                        '(println x)
                        'x)))
  (:value (last (interp '(define f (lambda (n) n))
                        '(f 1))))
  (:value (last (interp '(define f (lambda (n) (if (>= n 1) f 1)))
                        '(f 1))))
  (clojure.pprint/pprint
   (cleanup-trace
    (interp '(define fact (lambda (n) (if (<= n 1) 1 (* (fact (- n 1)) n))))
            '(fact 4))))
  (:value (last (interp '(define fact (lambda (n) (if (<= n 1) 1 (* (fact (- n 1)) n))))
                        '(fact 4))))
  (:value (last (interp '(define fact (lambda (n) (if (<= n 1) 1 (* (fact (- n 1)) n))))
                        '(fact 1000N))))
  )

;;; Evaluate this (e.g., with C-x C-e in Cider) to run the tests for
;;; this namespace:
;;; (clojure.test/run-tests 'revue.interpreter-test)
;;; Evaluate this to run the test for all namespaces:
;;; (clojure.test/run-all-tests #"^revue\..*-test")

Set the name attribute when defining functions