(ns frontend.components.add-projects (:require [cljs.core.async :as async :refer [>! <! alts! chan sliding-buffer close!]]
            [frontend.async :refer [raise!]]
            [frontend.datetime :as datetime]
            [frontend.models.user :as user-model]
            [frontend.models.repo :as repo-model]
            [frontend.components.common :as common]
            [frontend.components.forms :refer [managed-button]]
            [frontend.utils :as utils :refer-macros [inspect]]
            [frontend.utils.github :as gh-utils]
            [frontend.utils.vcs-url :as vcs-url]
            [om.core :as om :include-macros true]
            [om.dom :as dom :include-macros true]
            [clojure.string :as string]
            [goog.string :as gstring]
            [goog.string.format])
  (:require-macros [cljs.core.async.macros :as am :refer [go go-loop alt!]]
                   [frontend.utils :refer [html defrender]]))

(defn missing-scopes-notice [current-scopes missing-scopes]
  [:div
   [:div.alert.alert-error
    "We don't have all of the GitHub OAuth scopes we need to run your tests."
    ;; TODO translate CI.github
    [:a {:href (js/CI.github.authUrl (clj->js (concat missing-scopes current-scopes)))}
     (gstring/format "Click to grant Circle the %s %s."
                     (string/join "and " missing-scopes)
                     (if (< 1 (count missing-scopes)) "scope" "scopes"))]]])

(defn organization [org settings owner]
  (let [login (:login org)
        type (if (:org org) :org :user)]
    [:div.organization {:class (when (= {:login login :type type} (get-in settings [:add-projects :selected-org])) "active")}
     [:div.inner
      [:div.avatar
       [:a {:on-click #(raise! owner [:selected-add-projects-org {:login login :type type}])}
        [:img {:src (gh-utils/make-avatar-url org :size 50)
               :height 50}]]]
      [:div.other-stuff
       [:div.orgname
        [:a {:on-click #(raise! owner [:selected-add-projects-org {:login login :type type}])} login]
        [:small.github-url.pull-right
         [:a {:href (str "https://github.com/" login)
              :target "_blank"}
          [:i.fa.fa-github-alt ""]]]]]]]))

(defn organization-listing [data owner]
  (reify
    om/IDisplayName (display-name [_] "Organization Listing")
    om/IDidMount
    (did-mount [_]
      (utils/tooltip "#collaborators-tooltip-hack" {:placement "right"}))
    om/IRender
    (render [_]
      (let [user (:user data)
            settings (:settings data)
            org (:organizations user)]
        (html [:div
            [:div.overview
             [:span.big-number "1"]
             [:div.instruction "Choose a GitHub account that you are a member of or have access to."]]
            [:div.organizations
             [:h4 "Your accounts"]
             (map (fn [org] (organization org settings owner))
                   (:organizations user))
             (map (fn [org] (organization org settings owner))
                   (filter (fn [org] (= (:login user) (:login org)))
                           (:collaborators user)))
              [:div
               [:h4 "Users & organizations who have made pull requests to your repos"]
               (map (fn [org] (organization org settings owner))
                    (remove (fn [org] (= (:login user) (:login org)))
                            (:collaborators user)))]]])))))

(def repos-explanation
  [:div.add-repos
   [:h3 "Welcome to Circle"]
   [:ul
    [:li
     "Get started by selecting your GitHub username or organization on the left."]
    [:li "Choose a repo you want to test and we'll do the rest!"]]])

(defn repo-item [data owner]
  (reify
    om/IDisplayName (display-name [_] "repo-item")
    om/IDidMount
    (did-mount [_]
      (utils/tooltip (str "#view-project-tooltip-" (-> data :repo repo-model/id (string/replace #"[^\w]" "")))))
    om/IRenderState
    (render-state [_ {:keys [building?]}]
      (let [repo (:repo data)
            settings (:settings data)
            login (get-in settings [:add-projects :selected-org :login])
            type (get-in settings [:add-projects :selected-org :type])
            repo-id (repo-model/id repo)
            tooltip-id (str "view-project-tooltip-" (string/replace repo-id #"[^\w]" ""))
            settings (:settings data)
            should-build? (repo-model/should-do-first-follower-build? repo)]
        (html
         (cond (repo-model/can-follow? repo)
               [:li.repo-follow {:class (when should-build? "repo-1stfollow")}
                [:div.proj-name
                 [:span {:title (str (vcs-url/project-name (:vcs_url repo))
                                     (when (:fork repo) " (forked)"))}
                  (:name repo)]]
                (when building?
                  [:div.building "Starting first build..."])
                (managed-button
                 [:button {:on-click #(do (raise! owner [:followed-repo (assoc @repo
                                                                               :login login
                                                                               :type type)])
                                          (when should-build?
                                            (om/set-state! owner :building? true)))
                           :data-spinner true}
                  (if should-build? "Build project" "Watch project")])]

               (:following repo)
               [:li.repo-unfollow
                [:div.proj-name
                 [:span {:title (str (vcs-url/project-name (:vcs_url repo))
                                     (when (:fork repo) " (forked)"))}
                  (:name repo)]
                 [:a {:id tooltip-id
                      :title (str "View " (:name repo) (when (:fork repo) " (forked)") " project")
                      :href (vcs-url/project-path (:vcs_url repo))}
                  " "
                  [:i.fa.fa-external-link]]
                 (when (:fork repo)
                   [:span.forked (str " (" (vcs-url/org-name (:vcs_url repo)) ")")])]
                (managed-button
                 [:button {:on-click #(raise! owner [:unfollowed-repo (assoc @repo
                                                                             :login login
                                                                             :type type)])
                           :data-spinner true}
                  [:span "Stop watching project"]])]

               (repo-model/requires-invite? repo)
               [:li.repo-nofollow
                [:div.proj-name
                 [:span {:title (str (vcs-url/project-name (:vcs_url repo))
                                     (when (:fork repo) " (forked)"))}
                  (:name repo)]
                 (when (:fork repo)
                   [:span.forked (str " (" (vcs-url/org-name (:vcs_url repo)) ")")])]
                [:button {:on-click #(utils/open-modal "#inviteForm-addprojects")}
                 [:i.fa.fa-lock]
                 "Contact repo admin"]]))))))

(def invite-modal
  [:div#inviteForm-addprojects.fade.hide.modal
   {:tabIndex "-1",
    :role "dialog",
    :aria-labelledby "inviteFormLabel",
    :aria-hidden "true"}
   [:div.modal-header
    [:button.close
     {:type "button", :data-dismiss "modal", :aria-hidden "true"}
     "×"]
    [:h3#inviteFormLabel "This requires an Administrator"]]
   [:div.modal-body
    [:p
     "For security purposes only a project's Github administrator may setup Circle. Invite this project's admin(s) by sending them the link below and asking them to setup the project in Circle. You may also ask them to make you a Github administrator."]
    [:p [:input {:value "https://circleci.com/?join=dont-test-alone", :type "text"}]]]
   [:div.modal-footer
    [:button.btn.btn-primary
     {:data-dismiss "modal", :aria-hidden "true"}
     "Got it"]]])

(defrender repo-filter [settings owner]
  (let [repo-filter-string (get-in settings [:add-projects :repo-filter-string])]
    (html
     [:div.repo-filter
      ; [:i.fa.fa-search]
      [:input.unobtrusive-search
       {:placeholder "Filter repos..."
        :type "search"
        :value repo-filter-string
        :on-change #(utils/edit-input owner [:settings :add-projects :repo-filter-string] %)}]
      [:div.checkbox.pull-right.fork-filter
       [:label
        [:input {:type "checkbox"
                 :name "Show forks"
                 :on-change #(utils/toggle-input owner [:settings :add-projects :show-forks] %)}]
        "Show forks"]]])))

(defrender main [data owner]
  (let [user (:current-user data)
        settings (:settings data)
        repos (:repos data)
        repo-filter-string (get-in settings [:add-projects :repo-filter-string])
        show-forks (true? (get-in settings [:add-projects :show-forks]))]
    (html
     [:div.proj-wrapper
      (if-not (get-in settings [:add-projects :selected-org :login])
        repos-explanation
        (cond
         (nil? repos) [:div.loading-spinner common/spinner]
         (not (seq repos)) [:div
                            (om/build repo-filter settings)
                            [:ul.proj-list
                             [:li (str "No repos found for organization " (:selected-org data))]]]
         :else [:div
                (om/build repo-filter settings)
                [:ul.proj-list
                 (let [filtered-repos (sort-by :name (filter (fn [repo]
                                                               (and
                                                                (if show-forks
                                                                  true
                                                                  (not (:fork repo)))
                                                                (-> repo
                                                                    :name
                                                                    (.toLowerCase)
                                                                    (.indexOf (.toLowerCase repo-filter-string))
                                                                    (not= -1))))
                                                             repos))]
                   (map (fn [repo] (om/build repo-item {:repo repo
                                                        :settings settings}))
                        filtered-repos))]]))
      invite-modal])))

(defrender add-projects [data owner]
  (let [user (:current-user data)
        settings (:settings data)
        selected-org (get-in settings [:add-projects :selected-org :login])
        repo-key (gstring/format "%s.%s"
                                 selected-org
                                 (get-in settings [:add-projects :selected-org :type]))
        repos (get-in user [:repos repo-key])]
    (html
     [:div#add-projects
      [:header.main-head
       [:div.head-user
        [:h1 "Add Projects"]]]
      [:div#follow-contents
       [:div.follow-wrapper
        (when (seq (user-model/missing-scopes user))
          (missing-scopes-notice (:github_oauth_scopes user) (user-model/missing-scopes user)))
        [:h2 "Welcome!"]
        [:h3 "You're about to set up a new project in CircleCI."]
        [:p "CircleCI helps you ship better code, faster. To kick things off, you'll need to pick some projects to build:"]
        [:hr]
        [:div.org-listing
         (om/build organization-listing {:user user
                                         :settings settings})]
        [:hr]
        [:div.project-listing
         [:div.overview
          [:span.big-number "2"]
          [:div.instruction "Choose a repo, and we'll watch the repository for activity in GitHub such as pushes and pull requests. We'll kick off the first build immediately, and a new build will be initiated each time someone pushes commits."]]
         (om/build main {:user user
                         :repos repos
                         :selected-org selected-org
                         :settings settings})]]]])))

(ns frontend.components.add-projects (:require [cljs.core.async :as async :refer [>! <! alts! chan sliding-buffer close!]]
            [frontend.async :refer [raise!]]
            [frontend.datetime :as datetime]
            [frontend.models.user :as user-model]
            [frontend.models.repo :as repo-model]
            [frontend.components.common :as common]
            [frontend.components.forms :refer [managed-button]]
            [frontend.utils :as utils :refer-macros [inspect]]
            [frontend.utils.github :as gh-utils]
            [frontend.utils.vcs-url :as vcs-url]
            [om.core :as om :include-macros true]
            [om.dom :as dom :include-macros true]
            [clojure.string :as string]
            [goog.string :as gstring]
            [goog.string.format])
  (:require-macros [cljs.core.async.macros :as am :refer [go go-loop alt!]]
                   [frontend.utils :refer [html defrender]]))

(defn missing-scopes-notice [current-scopes missing-scopes]
  [:div
   [:div.alert.alert-error
    "We don't have all of the GitHub OAuth scopes we need to run your tests."
    ;; TODO translate CI.github
    [:a {:href (js/CI.github.authUrl (clj->js (concat missing-scopes current-scopes)))}
     (gstring/format "Click to grant Circle the %s %s."
                     (string/join "and " missing-scopes)
                     (if (< 1 (count missing-scopes)) "scope" "scopes"))]]])

(defn organization [org settings owner]
  (let [login (:login org)
        type (if (:org org) :org :user)]
    [:div.organization {:class (when (= {:login login :type type} (get-in settings [:add-projects :selected-org])) "active")}
     [:div.inner
      [:div.avatar
       [:a {:on-click #(raise! owner [:selected-add-projects-org {:login login :type type}])}
        [:img {:src (gh-utils/make-avatar-url org :size 50)
               :height 50}]]]
      [:div.other-stuff
       [:div.orgname
        [:a {:on-click #(raise! owner [:selected-add-projects-org {:login login :type type}])} login]
        [:small.github-url.pull-right
         [:a {:href (str "https://github.com/" login)
              :target "_blank"}
          [:i.fa.fa-github-alt ""]]]]]]]))

(defn organization-listing [data owner]
  (reify
    om/IDisplayName (display-name [_] "Organization Listing")
    om/IDidMount
    (did-mount [_]
      (utils/tooltip "#collaborators-tooltip-hack" {:placement "right"}))
    om/IRender
    (render [_]
      (let [user (:user data)
            settings (:settings data)
            org (:organizations user)]
        (html [:div
            [:div.overview
             [:span.big-number "1"]
             [:div.instruction "Choose a GitHub account that you are a member of or have access to."]]
            [:div.organizations
             [:h4 "Your accounts"]
             (map (fn [org] (organization org settings owner))
                   (:organizations user))
             (map (fn [org] (organization org settings owner))
                   (filter (fn [org] (= (:login user) (:login org)))
                           (:collaborators user)))
              [:div
               [:h4 "Users & organizations who have made pull requests to your repos"]
               (map (fn [org] (organization org settings owner))
                    (remove (fn [org] (= (:login user) (:login org)))
                            (:collaborators user)))]]])))))

(def repos-explanation
  [:div.add-repos
   [:h3 "Welcome to Circle"]
   [:ul
    [:li
     "Get started by selecting your GitHub username or organization on the left."]
    [:li "Choose a repo you want to test and we'll do the rest!"]]])

(defn repo-item [data owner]
  (reify
    om/IDisplayName (display-name [_] "repo-item")
    om/IDidMount
    (did-mount [_]
      (utils/tooltip (str "#view-project-tooltip-" (-> data :repo repo-model/id (string/replace #"[^\w]" "")))))
    om/IRenderState
    (render-state [_ {:keys [building?]}]
      (let [repo (:repo data)
            settings (:settings data)
            login (get-in settings [:add-projects :selected-org :login])
            type (get-in settings [:add-projects :selected-org :type])
            repo-id (repo-model/id repo)
            tooltip-id (str "view-project-tooltip-" (string/replace repo-id #"[^\w]" ""))
            settings (:settings data)
            should-build? (repo-model/should-do-first-follower-build? repo)]
        (html
         (cond (repo-model/can-follow? repo)
               [:li.repo-follow
                [:div.proj-name
                 [:span {:title (str (vcs-url/project-name (:vcs_url repo))
                                     (when (:fork repo) " (forked)"))}
                  (:name repo)]]
                (when building?
                  [:div.building "Starting first build..."])
                (managed-button
                 [:button {:on-click #(do (raise! owner [:followed-repo (assoc @repo
                                                                               :login login
                                                                               :type type)])
                                          (when should-build?
                                            (om/set-state! owner :building? true)))
                           :title (if should-build?
                                    "This project has never been built by CircleCI before. Clicking will cause CircleCI to start building the project."
                                    "This project has been built by CircleCI before. Clicking will cause builds for this project to show up for you in the UI.")
                           :data-spinner true}
                  (if should-build? "Build project" "Watch project")])]

               (:following repo)
               [:li.repo-unfollow
                [:div.proj-name
                 [:span {:title (str (vcs-url/project-name (:vcs_url repo))
                                     (when (:fork repo) " (forked)"))}
                  (:name repo)]
                 [:a {:id tooltip-id
                      :title (str "View " (:name repo) (when (:fork repo) " (forked)") " project")
                      :href (vcs-url/project-path (:vcs_url repo))}
                  " "
                  [:i.fa.fa-external-link]]
                 (when (:fork repo)
                   [:span.forked (str " (" (vcs-url/org-name (:vcs_url repo)) ")")])]
                (managed-button
                 [:button {:on-click #(raise! owner [:unfollowed-repo (assoc @repo
                                                                             :login login
                                                                             :type type)])
                           :data-spinner true}
                  [:span "Stop watching project"]])]

               (repo-model/requires-invite? repo)
               [:li.repo-nofollow
                [:div.proj-name
                 [:span {:title (str (vcs-url/project-name (:vcs_url repo))
                                     (when (:fork repo) " (forked)"))}
                  (:name repo)]
                 (when (:fork repo)
                   [:span.forked (str " (" (vcs-url/org-name (:vcs_url repo)) ")")])]
                [:button {:on-click #(utils/open-modal "#inviteForm-addprojects")}
                 [:i.fa.fa-lock]
                 "Contact repo admin"]]))))))

(def invite-modal
  [:div#inviteForm-addprojects.fade.hide.modal
   {:tabIndex "-1",
    :role "dialog",
    :aria-labelledby "inviteFormLabel",
    :aria-hidden "true"}
   [:div.modal-header
    [:button.close
     {:type "button", :data-dismiss "modal", :aria-hidden "true"}
     "×"]
    [:h3#inviteFormLabel "This requires an Administrator"]]
   [:div.modal-body
    [:p
     "For security purposes only a project's Github administrator may setup Circle. Invite this project's admin(s) by sending them the link below and asking them to setup the project in Circle. You may also ask them to make you a Github administrator."]
    [:p [:input {:value "https://circleci.com/?join=dont-test-alone", :type "text"}]]]
   [:div.modal-footer
    [:button.btn.btn-primary
     {:data-dismiss "modal", :aria-hidden "true"}
     "Got it"]]])

(defrender repo-filter [settings owner]
  (let [repo-filter-string (get-in settings [:add-projects :repo-filter-string])]
    (html
     [:div.repo-filter
      ; [:i.fa.fa-search]
      [:input.unobtrusive-search
       {:placeholder "Filter repos..."
        :type "search"
        :value repo-filter-string
        :on-change #(utils/edit-input owner [:settings :add-projects :repo-filter-string] %)}]
      [:div.checkbox.pull-right.fork-filter
       [:label
        [:input {:type "checkbox"
                 :name "Show forks"
                 :on-change #(utils/toggle-input owner [:settings :add-projects :show-forks] %)}]
        "Show forks"]]])))

(defrender main [data owner]
  (let [user (:current-user data)
        settings (:settings data)
        repos (:repos data)
        repo-filter-string (get-in settings [:add-projects :repo-filter-string])
        show-forks (true? (get-in settings [:add-projects :show-forks]))]
    (html
     [:div.proj-wrapper
      (if-not (get-in settings [:add-projects :selected-org :login])
        repos-explanation
        (cond
         (nil? repos) [:div.loading-spinner common/spinner]
         (not (seq repos)) [:div
                            (om/build repo-filter settings)
                            [:ul.proj-list
                             [:li (str "No repos found for organization " (:selected-org data))]]]
         :else [:div
                (om/build repo-filter settings)
                [:ul.proj-list
                 (let [filtered-repos (sort-by :name (filter (fn [repo]
                                                               (and
                                                                (if show-forks
                                                                  true
                                                                  (not (:fork repo)))
                                                                (-> repo
                                                                    :name
                                                                    (.toLowerCase)
                                                                    (.indexOf (.toLowerCase repo-filter-string))
                                                                    (not= -1))))
                                                             repos))]
                   (map (fn [repo] (om/build repo-item {:repo repo
                                                        :settings settings}))
                        filtered-repos))]]))
      invite-modal])))

(defrender add-projects [data owner]
  (let [user (:current-user data)
        settings (:settings data)
        selected-org (get-in settings [:add-projects :selected-org :login])
        repo-key (gstring/format "%s.%s"
                                 selected-org
                                 (get-in settings [:add-projects :selected-org :type]))
        repos (get-in user [:repos repo-key])]
    (html
     [:div#add-projects
      [:header.main-head
       [:div.head-user
        [:h1 "Add Projects"]]]
      [:div#follow-contents
       [:div.follow-wrapper
        (when (seq (user-model/missing-scopes user))
          (missing-scopes-notice (:github_oauth_scopes user) (user-model/missing-scopes user)))
        [:h2 "Welcome!"]
        [:h3 "You're about to set up a new project in CircleCI."]
        [:p "CircleCI helps you ship better code, faster. To kick things off, you'll need to pick some projects to build:"]
        [:hr]
        [:div.org-listing
         (om/build organization-listing {:user user
                                         :settings settings})]
        [:hr]
        [:div.project-listing
         [:div.overview
          [:span.big-number "2"]
          [:div.instruction "Choose a repo, and we'll watch the repository for activity in GitHub such as pushes and pull requests. We'll kick off the first build immediately, and a new build will be initiated each time someone pushes commits."]]
         (om/build main {:user user
                         :repos repos
                         :selected-org selected-org
                         :settings settings})]]]])))

Fix 'follow project' buttons and add a little copy.


(set-env!
 :resource-paths #{"resources"}
 :source-paths #{"src" "cljs"}
 :dependencies '[[org.clojure/clojure "1.8.0"]
                 [com.cemerick/piggieback "0.2.1"]
                 [org.clojure/tools.nrepl "0.2.12"]
                 [weasel "0.7.0" :exclusions [org.clojure/clojurescript]]
                 [green-tags "0.3.0-alpha"]
                 [hiccup "1.0.5"]
                 [boot-deps "0.1.6"]
                 [aleph "0.4.1"]
                 [ring "1.5.0"  :exclusions [org.clojure/java.classpath]]
                 [org.clojure/data.json "0.2.6"]
                 [org.clojure/clojurescript "1.9.229"]
                 [org.clojure/core.async "0.2.391"]
                 [org.omcljs/om "1.0.0-alpha44"]
                 [sablono "0.7.4"]
                 [juxt/dirwatch "0.2.3"]])

(require '[sledge.boot-build :refer :all])
(require '[weasel.repl.websocket])
(require '[cemerick.piggieback])

(task-options!
 pom {:project 'sledge
      :version "0.1.1"}
 jar {:main 'sledge.core}
 cljs {:main 'sledge.core
       :optimizations :whitespace
       :options {}
       :output-file "assets/js/main.js"}
 target {:dir #{"target/"}})

(deftask pig
  "Piggieback nrepl middleware"
  []
  (swap! @(resolve 'boot.repl/*default-middleware*)
         concat '[cemerick.piggieback/wrap-cljs-repl])
  identity)

(deftask reload-browser []
  (with-pre-wrap [fileset]
    (boot.util/info "reloading browser ...")
    (clojure.java.shell/sh "xdotool"
                           "search" "--onlyvisible"  "Sledge - Nightly"
                           "key" "F5")
    (boot.util/info "\n")
    fileset))

(defn wait-for-browser-repl []
  (cemerick.piggieback/cljs-repl
   (weasel.repl.websocket/repl-env :ip "0.0.0.0" :port 9001)))

(deftask build []
  (comp
   (aot :namespace #{'sledge.core})
   (pom)
   (cljs :optimizations :advanced)
   (uber)
   (jar)
   (sift :include #{#"project.jar$"})
   (target)))

(set-env!
 :resource-paths #{"resources"}
 :source-paths #{"src" "cljs"}
 :dependencies '[[org.clojure/clojure "1.9.0-alpha14"]
                 [com.cemerick/piggieback "0.2.1"]
                 [org.clojure/tools.nrepl "0.2.12"]
                 [weasel "0.7.0" :exclusions [org.clojure/clojurescript]]
                 [green-tags "0.3.0-alpha"]
                 [hiccup "1.0.5"]
                 [boot-deps "0.1.6"]
                 [aleph "0.4.2-alpha10"]
                 [ring "1.6.0-beta6"  :exclusions [org.clojure/java.classpath]]
                 [org.clojure/data.json "0.2.6"]
                 [org.clojure/clojurescript "1.9.293"]
                 [org.clojure/core.async "0.2.395"]
                 [org.omcljs/om "1.0.0-alpha47"]
                 [sablono "0.7.6"]
                 [juxt/dirwatch "0.2.3"]])

(require '[sledge.boot-build :refer :all])
(require '[weasel.repl.websocket])
(require '[cemerick.piggieback])

(task-options!
 pom {:project 'sledge
      :version "0.1.1"}
 jar {:main 'sledge.core}
 cljs {:main 'sledge.core
       :optimizations :whitespace
       :options {}
       :output-file "assets/js/main.js"}
 target {:dir #{"target/"}})

(deftask pig
  "Piggieback nrepl middleware"
  []
  (swap! @(resolve 'boot.repl/*default-middleware*)
         concat '[cemerick.piggieback/wrap-cljs-repl])
  identity)

(deftask reload-browser []
  (with-pre-wrap [fileset]
    (boot.util/info "reloading browser ...")
    (clojure.java.shell/sh "xdotool"
                           "search" "--onlyvisible"  "Sledge - Nightly"
                           "key" "F5")
    (boot.util/info "\n")
    fileset))

(defn wait-for-browser-repl []
  (cemerick.piggieback/cljs-repl
   (weasel.repl.websocket/repl-env :ip "0.0.0.0" :port 9001)))

(deftask build []
  (comp
   (aot :namespace #{'sledge.core})
   (pom)
   (cljs :optimizations :advanced)
   (uber)
   (jar)
   (sift :include #{#"project.jar$"})
   (target)))

update libs/clojure in preparation for core.spec


(def project 'parse-names)
(def version "0.1.0-SNAPSHOT")

(set-env! :resource-paths #{"resources" "src"}
          :source-paths   #{"test"}
          :dependencies   '[[org.clojure/clojure "RELEASE"]
                            [adzerk/boot-test "RELEASE" :scope "test"]
                            [adzerk/bootlaces "0.1.13" :scope "test"]
                            [org.clojars.bensu/commons-text "0.1-SNAPSHOT-0"]])

(task-options!
 pom {:project     project
      :version     version
      :description "FIXME: write description"
      :url         "http://example/FIXME"
      :scm         {:url "https://github.com/yourname/parse-names"}
      :license     {"Eclipse Public License"
                    "http://www.eclipse.org/legal/epl-v10.html"}})

(deftask build
  "Build and install the project locally."
  []
  (comp (pom) (jar) (install)))

(require '[adzerk.boot-test :refer [test]])
(require '[adzerk.bootlaces :refer :all])

(bootlaces! version)

(def project 'parse-names)
(def version "0.1.0-SNAPSHOT")

(set-env! :resource-paths #{"resources" "src"}
          :source-paths   #{"test"}
          :dependencies   '[[org.clojure/clojure "RELEASE"]
                            [adzerk/boot-test "RELEASE" :scope "test"]
                            [adzerk/bootlaces "0.1.13" :scope "test"]
                            [org.clojars.bensu/commons-text "0.1-SNAPSHOT-0"]])

(task-options!
 pom {:project     project
      :version     version
      :description ""
      :url         "http://github.com/bensu/parse-names"
      :scm         {:url "https://github.com/bensu/parse-names"}
      :license     {"Eclipse Public License"
                    "http://www.eclipse.org/legal/epl-v10.html"}})

(deftask build
  "Build and install the project locally."
  []
  (comp (pom) (jar) (install)))

(require '[adzerk.boot-test :refer [test]])
(require '[adzerk.bootlaces :refer :all])

(bootlaces! version)

Correct project metadata

Correct project metadata


; Iyye - AI agent
; Copyright (C) 2016-2018  Sasha Yumzya

; This program is free software: you can redistribute it and/or modify
; it under the terms of the GNU Affero General Public License as
; published by the Free Software Foundation, either version 3 of the
; License, or (at your option) any later version.

; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
; GNU Affero General Public License for more details.

; You should have received a copy of the GNU Affero General Public License
; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(ns iyye.subcon.knowledge.words
  (:require
    [clojure.tools.logging :as log]
    [iyye.bios.ioframes :as ioframes]
    [iyye.bios.persistence :as persistence]
    ;[iyye.subcon.knowledge.relation :as relation]
    ))

(def action-words (ref {}))
(def noun-words (ref {}))
;(def types-words (ref []))
;(def relations-words (ref []))
;(def instances-words (ref []))
;(def adjective-words (ref []))

(defrecord Iyye_ModalPredicate [AccordingTo When Time Prob])
(defrecord Iyye_Atom [Name Uname Builtin])
(defrecord Iyye_Relation [atom Predicate Types Function PredicateFunction Data])
(defrecord Iyye_Type [atom Relations])
(defrecord Iyye_Instance [atom type])

(def atoms-number (ref 0))
(defn inc-atoms! []
  (dosync (ref-set atoms-number (inc @atoms-number)))
  @atoms-number)

(defn create-iyye-atom [name & builtin]
  (let [uname (str name (inc-atoms!))
        b (if (nil? builtin) false (first builtin))
        atom (->Iyye_Atom name uname b)]
    atom))

(defn create-iyye-type [Name & builtin]
  (let [type-atom (create-iyye-atom Name builtin)
        type (->Iyye_Type type-atom [])]
    type))

(defn create-iyye-relation [Name Predicate Types Function PredicateFunction & builtin]
  (let [action-atom (create-iyye-atom Name builtin)
        relation (->Iyye_Relation action-atom Predicate Types Function PredicateFunction [])]
    relation))

(def time-start (persistence/current-time-to-string))
(defn get-supertypes [atype]
  "gets types: self, type, immidiate parents"               ; FIXME Yumzia:0 get all parents
  (when (not (= :UNKNOWN atype))
    (let [rels (:Relations atype)]
      (conj (for [supertype rels :when (:super (:Data supertype))]
              {:Name (:super (:Data supertype)) :Predicate (:Predicate supertype)})
              {:Name "type" :Predicate (->Iyye_ModalPredicate :IYE :AXIOM time-start :ALWAYS)}
              {:Name (:Name (:atom atype)) :Predicate (->Iyye_ModalPredicate :IYE :AXIOM time-start :ALWAYS)}))))

(defn create-iyye-instance [values])

(defn load-iyye-atom-from-db [uname])

(defn load-iyye-atoms-from-db [name & [dbname]])

(defn load-iyye-types-from-db [name]
  (load-iyye-atoms-from-db name "types"))

(defn load-iyye-relations-from-db [name]
  (load-iyye-atoms-from-db name "relations"))

(defn save-iyye-type-to-db [type]
  )
;(persistence/write-noun-to-db (into {} type))

(defn get-iyye-atoms [name builtins]
  "returns a list of found atoms with supplied name"
  (let [builtin-types
        (for [word (vals @builtins) :when (= (:Name (:atom word)) name)] word)]
    (if (empty? builtin-types) (list :UNKNOWN) builtin-types)))

(defn get-iyye-types [name]
  (get-iyye-atoms name noun-words))

(defn get-iyye-relations [name]
  (get-iyye-atoms name action-words))

(defn set-iyye-type! [type]
  (let [uname (:Uname (:atom type))
        builtin (:Builtin (:atom type))]
      (do
        (dosync (alter noun-words #(assoc % uname type)))
        (when (not builtin)
          (save-iyye-type-to-db type)))))

(defn check-params [action params]
  (let [act-params (:Types action)]
    (when (= (count params) (count act-params))
      (let [params-types (map #(get-supertypes %) params)
        ;   vec-params (vec (map #(:Name (:atom %)) params))
            pairs (map vector act-params params-types)
            ok (every? true? (for [cur pairs]
                               (if (= :UNKNOWN (first cur))
                                 (empty? (second cur))
                                 (some true?
                                       (map #(= (first cur) %) (map :Name (second cur)))))))]
    ok))))  ; FIXME Yumzya context aware compare

(defn apply-relation [relation params]
  (when (check-params relation params)
    ((:Function relation) params)))

(defn apply-query [relation params]
  (when (check-params relation params)
    ((:PredicateFunction relation) params)))

(defn- run-action [cmd params IO func]
  (let [actions-list (get-iyye-relations cmd)
        params-list (apply concat (map get-iyye-types params))]
    (case (count actions-list)
      0 (future (Thread/sleep 1000) (ioframes/process-output IO (str "failed to parse: no matching action to " cmd)))
      1 (let [action (first actions-list)
              result (func action params-list)]
          (if result
            (future (Thread/sleep 1000) (ioframes/process-output IO (pr-str result)))))
      (let [matching-actions
            (for [action actions-list :when (check-params action params-list)] action)]
        (if (empty? matching-actions)
          (future (Thread/sleep 800) (ioframes/process-output IO (pr-str "Cant find " cmd " " params)))
          (let [result (func (first matching-actions) params-list)]
            (if result
              (future (Thread/sleep 1000) (ioframes/process-output IO (pr-str result)))
              (future (Thread/sleep 1000) (ioframes/process-output IO (str "False"))))))))))

(defn action [cmd params IO]
  (if (= \? (last cmd))
    (run-action (subs cmd 0 (dec (count cmd))) params IO apply-query)
    (run-action cmd params IO apply-relation)))

; Iyye - AI agent
; Copyright (C) 2016-2018  Sasha Yumzya

; This program is free software: you can redistribute it and/or modify
; it under the terms of the GNU Affero General Public License as
; published by the Free Software Foundation, either version 3 of the
; License, or (at your option) any later version.

; This program is distributed in the hope that it will be useful,
; but WITHOUT ANY WARRANTY; without even the implied warranty of
; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
; GNU Affero General Public License for more details.

; You should have received a copy of the GNU Affero General Public License
; along with this program.  If not, see <http://www.gnu.org/licenses/>.

(ns iyye.subcon.knowledge.words
  (:require
    [clojure.tools.logging :as log]
    [iyye.bios.ioframes :as ioframes]
    [iyye.bios.persistence :as persistence]
    ;[iyye.subcon.knowledge.relation :as relation]
    ))

(def action-words (ref {}))
(def noun-words (ref {}))
;(def types-words (ref []))
;(def relations-words (ref []))
;(def instances-words (ref []))
;(def adjective-words (ref []))

(defrecord Iyye_ModalPredicate [AccordingTo When Time Prob])
(defrecord Iyye_Atom [Name Uname Builtin])
(defrecord Iyye_Relation [atom Predicate Types Function PredicateFunction Data])
(defrecord Iyye_Type [atom Relations])
(defrecord Iyye_Instance [atom type])

(def atoms-number (ref 0))
(defn inc-atoms! []
  (dosync (ref-set atoms-number (inc @atoms-number)))
  @atoms-number)

(defn create-iyye-atom [name & builtin]
  (let [uname (str name (inc-atoms!))
        b (if (nil? builtin) false (first builtin))
        atom (->Iyye_Atom name uname b)]
    atom))

(defn create-iyye-type [Name & builtin]
  (let [type-atom (create-iyye-atom Name builtin)
        type (->Iyye_Type type-atom [])]
    type))

(defn create-iyye-relation [Name Predicate Types Function PredicateFunction & builtin]
  (let [action-atom (create-iyye-atom Name builtin)
        relation (->Iyye_Relation action-atom Predicate Types Function PredicateFunction [])]
    relation))

(def time-start (persistence/current-time-to-string))
(defn get-supertypes [atype]
  "gets types: self, type, immidiate parents"               ; FIXME Yumzia:0 get all parents
  (if (not (:UNKNOWN atype))
    (let [rels (:Relations atype)]
      (conj (for [supertype rels :when (:super (:Data supertype))]
              {:Name (:super (:Data supertype)) :Predicate (:Predicate supertype)})
              {:Name "type" :Predicate (->Iyye_ModalPredicate :IYE :AXIOM time-start :ALWAYS)}
              {:Name (:Name (:atom atype)) :Predicate (->Iyye_ModalPredicate :IYE :AXIOM time-start :ALWAYS)}))
    {:UNKNOWN (:UNKNOWN atype)}))

(defn create-iyye-instance [values])

(defn load-iyye-atom-from-db [uname])

(defn load-iyye-atoms-from-db [name & [dbname]])

(defn load-iyye-types-from-db [name]
  (load-iyye-atoms-from-db name "types"))

(defn load-iyye-relations-from-db [name]
  (load-iyye-atoms-from-db name "relations"))

(defn save-iyye-type-to-db [type]
  )
;(persistence/write-noun-to-db (into {} type))

(defn get-iyye-atoms [name builtins]
  "returns a list of found atoms with supplied name"
  (let [builtin-types
        (for [word (vals @builtins) :when (= (:Name (:atom word)) name)] word)]
    (if (empty? builtin-types) (list {:UNKNOWN name}) builtin-types)))

(defn get-iyye-types [name]
  (get-iyye-atoms name noun-words))

(defn get-iyye-relations [name]
  (get-iyye-atoms name action-words))

(defn set-iyye-type! [type]
  (let [uname (:Uname (:atom type))
        builtin (:Builtin (:atom type))]
      (do
        (dosync (alter noun-words #(assoc % uname type)))
        (when (not builtin)
          (save-iyye-type-to-db type)))))

(defn check-params [action params]
  (let [act-params (:Types action)]
    (when (= (count params) (count act-params))
      (let [params-types (map #(get-supertypes %) params)
        ;   vec-params (vec (map #(:Name (:atom %)) params))
            pairs (map vector act-params params-types)
            ok (every? true? (for [cur pairs]
                               (if (= :UNKNOWN (first cur))
                                 (if (:UNKNOWN (second cur)) true false)
                                 (some true?
                                       (map #(= (first cur) %) (map :Name (second cur)))))))]
    ok))))  ; FIXME Yumzya context aware compare

(defn apply-relation [relation params]
  (when (check-params relation params)
    ((:Function relation) params)))

(defn apply-query [relation params]
  (when (check-params relation params)
    ((:PredicateFunction relation) params)))

(defn- run-action [cmd params IO func]
  (let [actions-list (get-iyye-relations cmd)
        params-list (apply concat (map get-iyye-types params))]
    (case (count actions-list)
      0 (future (Thread/sleep 1000) (ioframes/process-output IO (str "failed to parse: no matching action to " cmd)))
      1 (let [action (first actions-list)
              result (func action params-list)]
          (if result
            (future (Thread/sleep 1000) (ioframes/process-output IO (pr-str result)))))
      (let [matching-actions
            (for [action actions-list :when (check-params action params-list)] action)]
        (if (empty? matching-actions)
          (future (Thread/sleep 800) (ioframes/process-output IO (pr-str "Cant find " cmd " " params)))
          (let [result (func (first matching-actions) params-list)]
            (if result
              (future (Thread/sleep 1000) (ioframes/process-output IO (pr-str result)))
              (future (Thread/sleep 1000) (ioframes/process-output IO (str "False"))))))))))

(defn action [cmd params IO]
  (if (= \? (last cmd))
    (run-action (subs cmd 0 (dec (count cmd))) params IO apply-query)
    (run-action cmd params IO apply-relation)))

Update words.clj

Update words.clj


(ns emulator-chip8.opcode
  #?(:cljs (:require-macros [emulator-chip8.opcode :refer [defop]]))
  (:require
   #?(:clj
      [clojure.pprint :refer [cl-format]]
      :cljs
      [cljs.pprint :refer [cl-format]])))

(comment
  (ns emulator-chip8.opcode
    (:require
     [clojure.pprint :refer [cl-format]])))

;; #?(:clj
;;    (defmacro defop
;;      [name & body]
;;      (let [name (symbol (str "opcode-" name))
;;            args [{'r :registers 'm :memory :as 'cpu}
;;                  'addr-mode
;;                  ['n 'n-addr]]]
;;        `(defn ~name ~args ~@body))))

;; #?(:clj
;;    (defmacro to-opcode-func [name]
;;      (let [n  (symbol (str name))]
;;        `(~n)
;;        )))

;; A list store all opcode keys
;; This list will fetch value from `defop' macro.
(defonce opcode-list (atom #{}))

;; A simple handler to create opcode function with defmethod
(defmulti handler (fn [state opcode] (:type opcode)))

;; defop macro is to reduce some dulpicate code for create
;; opcode handler by defmethod.
;; This macro also add value to opcode-list to let cpu know known opcode.
;;#?(:clj
(defmacro defop
  [key & body]
  `(do
     (defmethod handler ~key
       ~['state {:keys ['NNN 'NN 'N 'VX 'VY]}]
       ~@body)

     (swap! opcode-list conj ~key)
     )
  )
;;)

(comment
  (defn make-handler-sets
    "Create possible opcode set for opcode-list"
    [opcode]
    ;; TODO: cljs lack format
    (let [code (format "%04X" opcode)
          ZNNN (format "%SNNN" (subs code 0 1))
          ZXNN (format "%SXNN" (subs code 0 1))
          ZXYN (format "%SXYN" (subs code 0 1))
          ZXYZ (format "%SXY%S" (subs code 0 1) (subs code 3 4))
          ZXZZ (format "%SX%S"  (subs code 0 1) (subs code 2 4))]
      (->> (list code ZNNN ZXNN ZXZZ ZXYN ZXYZ)
           (map keyword)
           (set)))) )

(defn make-handler-sets
  "Create possible opcode set for opcode-list"
  [opcode]
  ;; TODO: cljs lack format
  (let [code (cl-format nil "~4,'0x" opcode)
        ZNNN (cl-format nil "~ANNN" (subs code 0 1))
        ZXNN (cl-format nil "~AXNN" (subs code 0 1))
        ZXYN (cl-format nil "~AXYN" (subs code 0 1))
        ZXYZ (cl-format nil "~AXY~A" (subs code 0 1) (subs code 3 4))
        ZXZZ (cl-format nil "~AX~A"  (subs code 0 1) (subs code 2 4))]
    (->> (list code ZNNN ZXNN ZXZZ ZXYN ZXYZ)
         (map keyword)
         (set))))

(comment
  (defn make-handler-args
    "Parse the code to find how many VX, VY, NNN, NN, N
  and create argument lists."
    [opcode]
    ;; TODO: cljs lack format
    (let [code (format "%04X" opcode)]
      {:NNN (read-string (subs code 1 4))
       :NN  (read-string (subs code 2 4))
       :N   (read-string (subs code 3 4))
       :VX  (read-string (subs code 1 2))
       :VY  (read-string (subs code 2 3))})))

(defn make-handler-args
  "Parse the code to find how many VX, VY, NNN, NN, N
  and create argument lists."
  [opcode]
  ;; TODO: cljs lack format
  (let [code (cl-format nil "~4,'0x" opcode)]
    {:NNN (read-string (subs code 1 4))
     :NN  (read-string (subs code 2 4))
     :N   (read-string (subs code 3 4))
     :VX  (read-string (subs code 1 2))
     :VY  (read-string (subs code 2 3))}))

(defn find-match-handler
  "Search for matching handler in handler list.
  If nothing find, return nil else return keyword."
  [handler opcode]
  (some (make-handler-sets opcode) handler))

(defn build-opmap
  [opcode]
  (let [args (make-handler-args opcode)]
    (merge args
           {:type (find-match-handler @opcode-list opcode)})))

(defn step
  [state opcode]
  (try (handler state opcode)
       ;; TODO: catch
       )
  )

;; (defmethod handler :0NNN
;;   [state opcode]
;;   (str (:tpye opcode) " will howl and murder"))

;; http://stackoverflow.com/questions/24897818/how-to-add-docstring-support-to-defn-like-clojure-macro

;; defmulti ?
;; http://www.braveclojure.com/multimethods-records-protocols/

;; Execute machine language subroutine at address NNN
(defop :0NNN
  )

;; Clear the screen
(defop :00E0
  )

;; Return from a subroutine
(defop :00EE
  )

;; Jump to address NNN
(defop :1NNN
  (merge state {:PC NNN}))

;; Execute subroutine starting at address NNN
(defop :2NNN
  )

;; Skip the following instruction if the value of register VX equals NN
(defop :3XNN
  (if (= (nth (:VX state) VX) NN)
    ;; skip next
    (println "TODO")
    ))

;; Skip the following instruction if the value of register VX is not equal to NN
(defop :4XNN
  )

;; Skip the following instruction if the value of register VX is equal to the
;; value of register VY
(defop :5XY0
  )

;; Store number NN in register VX.
(defop :6XNN
  (merge state {:VX (assoc (:VX state) VX)})
  )

;; Add the value NN to register VX.
(defop :7XNN
  )

;; Store the value of register VY in register VX.
(defop :8XY0
  )

;; Set VX to VX OR VY.
(defop :8XY1
  )

;; Set VX to VX AND VY.
(defop :8XY2
  )

;; Set VX to VX XOR VY.
(defop :8XY3
  )

;; Add the value of register VY to register VX.
;;  Set VF to 1 if a carry occurs
;;  Set VF to 0 if a carry does not occur.
(defop :8XY4
  )

;; Subtract the value of register VY from register VX
;; Set VF to 0 if a borrow occurs
;; Set VF to 1 if a borrow does not occur.
(defop :8XY5
  )

;; Store the value of register VY shifted right one bit in register VX.
;; Set register VF to the least significant bit prior to the shift.
(defop :8XY6
  )

;; Set register VX to the value of VY minus VX
;; Set VF to 00 if a borrow occurs
;; Set VF to 01 if a borrow does not occur
(defop :8XY7
  )

;; Store the value of register VY shifted left one bit in register VX.
;; Set register VF to the most significant bit prior to the shift.
(defop :8XYE
  )

;; Skip the following instruction if the value of register VX is not equal to
;; the value of register VY.
(defop :9XY0
  )

;; Store memory address NNN in register I
(defop :ANNN

  )

;; Jump to address NNN + V0
(defop :BNNN
  )

;; Set VX to a random number with a mask of NN
(defop :CXNN
  )

;; Draw a sprite at position VX, VY with N bytes of sprite data starting at the
;; address stored in I. Set VF to 01 if any set pixels are changed to unset, and
;; 00 otherwise
(defop :DXYN
  )

;; Skip the following instruction if the key corresponding to the hex value
;; currently stored in register VX is pressed.
(defop :EX9E
  )

;; Skip the following instruction if the key corresponding to the hex value
;; currently stored in register VX is not pressed.
(defop :EXA1
  )

;; Store the current value of the delay timer in register VX.
(defop :FX07
  )

;; Wait for a keypress and store the result in register VX.
(defop :FX0A
  )

;; Set the delay timer to the value of register VX.
(defop :FX15
  )

;; Set the sound timer to the value of register VX.
(defop :FX18
  )

;; Add the value stored in register VX to register I.
(defop :FX1E
  )

;; Set I to the memory address of the sprite data corresponding to the
;; hexadecimal digit stored in register VX.
(defop :FX29
  )

;; Store the binary-coded decimal equivalent of the value stored in register VX
;; at addresses I, I + 1, and I + 2.
(defop :FX33
  )

;; Store the values of registers V0 to VX inclusive in memory starting at
;;  address I, I is set to I + X + 1 after operation.
(defop :FX55
  )

;; Fill registers V0 to VX inclusive with the values stored in memory starting
;; at address I, I is set to I + X + 1 after operation.
(defop :FX65
  )

;;;; Simple Testing Area
(comment

  ;; show opcode-list value
  @opcode-list

  ;; opcode-list should contains 35 opcode
  (= 35 (count @opcode-list))

  ;; Expand the defop macro
  (clojure.pprint/pprint
   (macroexpand
    '(defop :0NNN
       (println "This is the result of defop macro"))))

  ;; Get the handler sets
  (make-handler-sets 0x123) ; => #{:0XNN :0XYN :0123 :0X23 :0NNN :0XY3}

  ;; test with `FX55'
  (make-handler-sets 0xf155)  ; => #{:FXY5 :FNNN :FXYN :FX55 :F155 :FXNN}
  (make-handler-args 0xf155)  ; =>  {:NNN 155, :NN 55, :N 5, :VX 1, :VY 5}
  (find-match-handler @opcode-list 0xf155) ; => :FX55

  ;; build the opmap with :type
  (build-opmap 0xf155) ; => {:NNN 155, :NN 55, :N 5, :VX 1, :VY 5, :type :FX55}

  )

(ns emulator-chip8.opcode
  #?(:cljs (:require-macros [emulator-chip8.opcode :refer [defop]]))
  (:require
   #?(:clj
      [clojure.pprint :refer [cl-format]]
      :cljs
      [cljs.pprint :refer [cl-format]])))

(comment
  (ns emulator-chip8.opcode
    (:require
     [clojure.pprint :refer [cl-format]])))

;; #?(:clj
;;    (defmacro defop
;;      [name & body]
;;      (let [name (symbol (str "opcode-" name))
;;            args [{'r :registers 'm :memory :as 'cpu}
;;                  'addr-mode
;;                  ['n 'n-addr]]]
;;        `(defn ~name ~args ~@body))))

;; #?(:clj
;;    (defmacro to-opcode-func [name]
;;      (let [n  (symbol (str name))]
;;        `(~n)
;;        )))

;; A list store all opcode keys
;; This list will fetch value from `defop' macro.
(defonce opcode-list (atom #{}))

;; A simple handler to create opcode function with defmethod
(defmulti handler (fn [state opcode] (:type opcode)))

;; defop macro is to reduce some dulpicate code for create
;; opcode handler by defmethod.
;; This macro also add value to opcode-list to let cpu know known opcode.
;;#?(:clj
(defmacro defop
  [key & body]
  `(do
     (defmethod handler ~key
       ~['state {:keys ['NNN 'NN 'N 'VX 'VY]}]
       ~@body)

     (swap! opcode-list conj ~key)
     )
  )
;;)

(defn make-handler-sets
  "Create possible opcode set for opcode-list"
  [opcode]
  (let [code (cl-format nil "~4,'0x" opcode)
        ZNNN (cl-format nil "~ANNN" (subs code 0 1))
        ZXNN (cl-format nil "~AXNN" (subs code 0 1))
        ZXYN (cl-format nil "~AXYN" (subs code 0 1))
        ZXYZ (cl-format nil "~AXY~A" (subs code 0 1) (subs code 3 4))
        ZXZZ (cl-format nil "~AX~A"  (subs code 0 1) (subs code 2 4))]
    (->> (list code ZNNN ZXNN ZXZZ ZXYN ZXYZ)
         (map keyword)
         (set))))

(defn make-handler-args
  "Parse the code to find how many VX, VY, NNN, NN, N
  and create argument lists."
  [opcode]
  (let [code (cl-format nil "~4,'0x" opcode)]
    {:NNN (read-string (subs code 1 4))
     :NN  (read-string (subs code 2 4))
     :N   (read-string (subs code 3 4))
     :VX  (read-string (subs code 1 2))
     :VY  (read-string (subs code 2 3))}))

(defn find-match-handler
  "Search for matching handler in handler list.
  If nothing find, return nil else return keyword."
  [handler opcode]
  (some (make-handler-sets opcode) handler))

(defn build-opmap
  [opcode]
  (let [args (make-handler-args opcode)]
    (merge args
           {:type (find-match-handler @opcode-list opcode)})))

(defn step
  [state opcode]
  (try (handler state opcode)
       ;; TODO: catch
       )
  )

;; (defmethod handler :0NNN
;;   [state opcode]
;;   (str (:tpye opcode) " will howl and murder"))

;; http://stackoverflow.com/questions/24897818/how-to-add-docstring-support-to-defn-like-clojure-macro

;; defmulti ?
;; http://www.braveclojure.com/multimethods-records-protocols/

;; Execute machine language subroutine at address NNN
(defop :0NNN
  )

;; Clear the screen
(defop :00E0
  )

;; Return from a subroutine
(defop :00EE
  )

;; Jump to address NNN
(defop :1NNN
  (merge state {:PC NNN}))

;; Execute subroutine starting at address NNN
(defop :2NNN
  )

;; Skip the following instruction if the value of register VX equals NN
(defop :3XNN
  (if (= (nth (:VX state) VX) NN)
    ;; skip next
    (println "TODO")
    ))

;; Skip the following instruction if the value of register VX is not equal to NN
(defop :4XNN
  )

;; Skip the following instruction if the value of register VX is equal to the
;; value of register VY
(defop :5XY0
  )

;; Store number NN in register VX.
(defop :6XNN
  (merge state {:VX (assoc (:VX state) VX)})
  )

;; Add the value NN to register VX.
(defop :7XNN
  )

;; Store the value of register VY in register VX.
(defop :8XY0
  )

;; Set VX to VX OR VY.
(defop :8XY1
  )

;; Set VX to VX AND VY.
(defop :8XY2
  )

;; Set VX to VX XOR VY.
(defop :8XY3
  )

;; Add the value of register VY to register VX.
;;  Set VF to 1 if a carry occurs
;;  Set VF to 0 if a carry does not occur.
(defop :8XY4
  )

;; Subtract the value of register VY from register VX
;; Set VF to 0 if a borrow occurs
;; Set VF to 1 if a borrow does not occur.
(defop :8XY5
  )

;; Store the value of register VY shifted right one bit in register VX.
;; Set register VF to the least significant bit prior to the shift.
(defop :8XY6
  )

;; Set register VX to the value of VY minus VX
;; Set VF to 00 if a borrow occurs
;; Set VF to 01 if a borrow does not occur
(defop :8XY7
  )

;; Store the value of register VY shifted left one bit in register VX.
;; Set register VF to the most significant bit prior to the shift.
(defop :8XYE
  )

;; Skip the following instruction if the value of register VX is not equal to
;; the value of register VY.
(defop :9XY0
  )

;; Store memory address NNN in register I
(defop :ANNN

  )

;; Jump to address NNN + V0
(defop :BNNN
  )

;; Set VX to a random number with a mask of NN
(defop :CXNN
  )

;; Draw a sprite at position VX, VY with N bytes of sprite data starting at the
;; address stored in I. Set VF to 01 if any set pixels are changed to unset, and
;; 00 otherwise
(defop :DXYN
  )

;; Skip the following instruction if the key corresponding to the hex value
;; currently stored in register VX is pressed.
(defop :EX9E
  )

;; Skip the following instruction if the key corresponding to the hex value
;; currently stored in register VX is not pressed.
(defop :EXA1
  )

;; Store the current value of the delay timer in register VX.
(defop :FX07
  )

;; Wait for a keypress and store the result in register VX.
(defop :FX0A
  )

;; Set the delay timer to the value of register VX.
(defop :FX15
  )

;; Set the sound timer to the value of register VX.
(defop :FX18
  )

;; Add the value stored in register VX to register I.
(defop :FX1E
  )

;; Set I to the memory address of the sprite data corresponding to the
;; hexadecimal digit stored in register VX.
(defop :FX29
  )

;; Store the binary-coded decimal equivalent of the value stored in register VX
;; at addresses I, I + 1, and I + 2.
(defop :FX33
  )

;; Store the values of registers V0 to VX inclusive in memory starting at
;;  address I, I is set to I + X + 1 after operation.
(defop :FX55
  )

;; Fill registers V0 to VX inclusive with the values stored in memory starting
;; at address I, I is set to I + X + 1 after operation.
(defop :FX65
  )

;;;; Simple Testing Area
(comment

  ;; show opcode-list value
  @opcode-list

  ;; opcode-list should contains 35 opcode
  (= 35 (count @opcode-list))

  ;; Expand the defop macro
  (clojure.pprint/pprint
   (macroexpand
    '(defop :0NNN
       (println "This is the result of defop macro"))))

  ;; Get the handler sets
  (make-handler-sets 0x123) ; => #{:0XNN :0XYN :0123 :0X23 :0NNN :0XY3}

  ;; test with `FX55'
  (make-handler-sets 0xf155)  ; => #{:FXY5 :FNNN :FXYN :FX55 :F155 :FXNN}
  (make-handler-args 0xf155)  ; =>  {:NNN 155, :NN 55, :N 5, :VX 1, :VY 5}
  (find-match-handler @opcode-list 0xf155) ; => :FX55

  ;; build the opmap with :type
  (build-opmap 0xf155) ; => {:NNN 155, :NN 55, :N 5, :VX 1, :VY 5, :type :FX55}

  )

drop old version

drop old version

Signed-off-by: Yen-Chin Lee <082d453d72dce940e12089a4ad48b97cfe1f3ec4@gmail.com>


(in-ns 'atom-finder.classifier)
(import '(org.eclipse.cdt.core.dom.ast IASTNode IASTName IASTIdExpression IASTBinaryExpression IASTUnaryExpression IASTExpressionStatement IASTPreprocessorFunctionStyleMacroDefinition IASTDoStatement IASTLiteralExpression IASTPreprocessorMacroExpansion cpp.ICPPASTTemplateId IASTCastExpression IASTFunctionCallExpression IASTEqualsInitializer IASTIfStatement IASTWhileStatement IASTForStatement IASTDoStatement IASTArraySubscriptExpression IASTExpressionList IASTFieldReference
IASTArrayModifier IASTBinaryExpression IASTCaseStatement IASTCastExpression IASTConditionalExpression IASTDoStatement IASTEnumerationSpecifier IASTExpressionStatement IASTFieldDeclarator IASTFieldReference IASTForStatement IASTFunctionCallExpression IASTIfStatement IASTInitializerExpression IASTReturnStatement IASTSimpleDeclSpecifier IASTSwitchStatement IASTUnaryExpression IASTWhileStatement IASTProblem)
        '(org.eclipse.cdt.core.dom.ast.cpp ICPPASTArrayDesignator ICPPASTConstructorChainInitializer ICPPASTConstructorInitializer ICPPASTDeleteExpression ICPPASTFunctionDeclarator ICPPASTNewExpression ICPPASTPackExpansionExpression ICPPASTSimpleTypeConstructorExpression ICPPASTTemplatedTypeTemplateParameter ICPPASTTypenameExpression)
        '(org.eclipse.cdt.core.dom.ast.gnu cpp.IGPPASTSimpleDeclSpecifier c.IGCCASTArrayRangeDesignator c.IGCCASTSimpleDeclSpecifier IGNUASTGotoStatement )
        '(org.eclipse.cdt.core.dom.ast.c ICASTArrayDesignator)
        '(org.eclipse.cdt.internal.core.parser.scanner ASTFunctionStyleMacroDefinition ASTMacroDefinition)
        '(org.eclipse.cdt.internal.core.dom.parser.cpp CPPASTUnaryExpression CPPASTExpressionList )
        )

(s/defn valid-node?
  [node :- (s/maybe IASTNode)]
  (and node (not (instance? IASTProblem node))))

;;https://stackoverflow.com/questions/9568050/in-clojure-how-to-write-a-function-that-applies-several-string-replacements
(s/defn replace-map
  "given an input string and a hash-map, returns a new string with all
   keys in map found in input replaced with the value of the key"
  [replacements :- {s/Str s/Str} target :- s/Str]
  (reduce (fn [target [pattern replacement]]
            (str/replace target (re-pattern pattern) replacement))
          target replacements))

(s/defn id-replace-map
  "replace identifiers"
  [replacements :- {s/Str s/Str} target :- s/Str]
  (replace-map
   (->> replacements
        ;; don't match ids inside other ids
        (map-keys #(str "(?<!\\w)" (java.util.regex.Pattern/quote %) "(?!\\w)"))
        (map-values str/re-quote-replacement))
   target))

(extend-protocol atom-finder.util/ASTTree clojure.lang.ISeq
  (ast-node [lst] (first lst))
  (children [lst] (rest lst)))

(extend-protocol atom-finder.util/ASTTree nil
  (ast-node [lst] nil)
  (children [lst] '()))

(defn seq-tree
  "A tree of nested lists that represents the AST"
  [node]
  (cons node (map seq-tree (children node))))

(defn prune-seq-tree
  "Form new leaves at a given predicate"
  [f any-tree]
  (let [[x & xs] (if (seqable? any-tree) any-tree (seq-tree any-tree))]
    (cons x
          (->> xs (map #(if (f (ast-node %1)) '() %1))  (map #(if (= '() %1) '() (prune-seq-tree f %1)))))))

(defn prune-terminals
  [tree]
  (prune-seq-tree (fn [node] (any-pred? #(instance? % node) [IASTIdExpression IASTLiteralExpression])) tree))

(s/defn expansion-container
  "The AST node that fully encloses a macro expansion"
  [expansion :- IASTPreprocessorMacroExpansion]
    (some->> expansion location-parent greatest-trivial-parent))

(s/defn expansion-parent
  "The parent of the AST node that fully encloses a macro expansion"
  [expansion :- IASTPreprocessorMacroExpansion]
    (some->> expansion expansion-container parent parent))

;; the template is being parsed as greater-than + int + less-than, just
;; ignore these some-how. maybe by ignoring every template in the expanded
;; case, or every tree (greater, X, lessthan) tree in the un-expanded?
(s/defn template-misparse?
  "sometimes the parser screws up A<b>::c so check if that happened"
  [expanded :- IASTNode unexpanded :- ExprOperator]
  (and (->> unexpanded :name (#{:lessThan :greaterThan}))
       (->> expanded (filter-tree (partial instance? ICPPASTTemplateId)) empty? not)))

(defn parse-macro-def
  [macro-def]
  (let [[all name args body] (->> macro-def str (re-find #"^([^=(]*)(?:\(([^)]*)\))?=(.*)"))]
    {:name name
     :args (some-<>> args (str/split <> #",") (remove empty?))
     :body body}))

(s/defn macro-defs-by-name {s/Str IASTPreprocessorMacroDefinition}
  [root :- IASTTranslationUnit]
  (->> root .getMacroDefinitions (map (juxt #(-> % .getName str) identity)) (into {})))

;; This doesn't catch cases where Macros are redefined throughout the file
(s/defn macro-body-str
  "Expand the body of the macro defnition"
  [macro-exp :- IASTPreprocessorMacroExpansion]
  (->> macro-exp .getMacroDefinition parse-macro-def :body))

'((->> "
  #define N	x
  #define M(x)  N(x)
  int y = M();
" parse-source .getMacroExpansions first macro-body-str))

(s/defn substituting-macro?
  [exp :- IASTPreprocessorMacroExpansion]
  (->> exp macro-body-str (re-find #"#")))

(s/defn outer-macro-operator-atom? :- (s/maybe IASTNode)
  "Does this expansion lead to a confusion AST tree outside of itself"
  [expansion :- IASTPreprocessorMacroExpansion]
  (let [exp-node (expansion-parent expansion)
        expanded   (some->> exp-node expr-operator)
        unexpanded (some->> exp-node write-tree parse-frag expr-operator)]
    (when (and (not (substituting-macro? expansion))
               expanded unexpanded
               (not= expanded unexpanded)
               (not (template-misparse? exp-node unexpanded)))
      exp-node)))

(s/defn macro-outer-precedence-finder
  [root :- IASTTranslationUnit]
  (->> root .getMacroExpansions (keep outer-macro-operator-atom?)))

(s/defn expansion-args-tree
  "Take the arguments to a macro and parse them into ASTs"
  [exp :- IASTPreprocessorMacroExpansion]
  ;; todo, is there a function that does this regex already
  (let [arg-str  (some->> exp str (re-find #"(?s)\w+\((.*)\)") second)
        arg-expr (some->> arg-str parse-frag)]
    (when arg-expr
      (cond
        (= arg-str "")
          []
        (instance? IASTExpressionList arg-expr)   ;; multiple args
          (children arg-expr)
        (instance? IASTProblem arg-expr) ;; statements as args?
          (let [parsed-args (some-<>> arg-str (str/split <> #",") (map parse-frag))]
            (when (every? valid-node? parsed-args)
              parsed-args))
        :else [arg-expr]                          ;; single arg
        ))))

(s/defn expansion-args-str :- [s/Str]
  "Extract the code in the arguments to a macro"
  [exp :- IASTPreprocessorMacroExpansion]
  (->> exp expansion-args-tree (map write-tree)))

(s/defn id-name
  [node :- IASTNode]
  (cond (instance? IASTIdExpression node) (.getName node)
        (instance? IASTName node) node
        :else nil))

(s/defn -maybe-set-value!
  [getter setter node replacements]
  (when-let* [operand     (getter node)
              name        (id-name operand)
              replacement (-> name str replacements)
              _           (instance? IASTExpression replacement)
              ]
       (doto node
         (setter (.copy (cond (instance? IASTIdExpression operand) replacement
                              (instance? IASTName operand) (.getName replacement)))))))

(s/defn -maybe-set-args!
  [node :- IASTFunctionCallExpression replacements]
  (let [args (.getArguments node)]
    (->> args
         count
         range
         (map (fn [idx] (-maybe-set-value!
                         (fn [_] (nth args idx))
                         (fn [_ new-child] (aset args idx new-child))
                         node replacements)))
         dorun)

    (doto node (.setArguments args))))

(s/defn -maybe-set-expr-list!
  [node :- CPPASTExpressionList replacements]
  (doseq [expr (.getExpressions node)]
    (-maybe-set-value!
     (fn [node] expr)
     (fn [_ new-child] (.replace node expr new-child))
     node replacements))
  node)

(s/defn -maybe-set-operand!
  "Take an identifier, and replace it with its full tree"
  [method node replacements]
  (-maybe-set-value! #(call-method % (str 'get method))
                     #(call-method %1 (str 'set method) %2)
                     node replacements))

(s/defn -maybe-set-operands!
  [node replacements & methods]
  (->> methods
       (map #(-maybe-set-operand! %1 node replacements))
       doall
       (some identity)))
(def expression-sites [
[IASTArrayModifier "ConstantExpression"]
[IASTArraySubscriptExpression "Argument" "ArrayExpression"]
[IASTBinaryExpression "Operand1" "Operand2"]
[IASTCaseStatement "Expression"]
[IASTCastExpression "Operand"]
[IASTConditionalExpression "LogicalConditionExpression" "PositiveResultExpression" "NegativeResultExpression"]
[IASTDoStatement "Condition"]
[IASTEnumerationSpecifier "Value"]
[IASTEqualsInitializer "InitializerClause"]
[IASTExpressionStatement "Expression"]
[IASTFieldDeclarator "BitFieldSize"]
[IASTFieldReference "FieldOwner" "FieldName"]
[IASTForStatement "ConditionExpression" "IterationExpression"]
[IASTFunctionCallExpression "FunctionNameExpression"]
[IASTIfStatement "ConditionExpression"]
[IASTInitializerExpression "Expression"]
[IASTReturnStatement "ReturnValue"]
[IASTSimpleDeclSpecifier "DeclTypeExpression"]
[IASTSwitchStatement "ControllerExpression"]
[IASTUnaryExpression "Operand"]
[IASTWhileStatement "Condition"]
[ICASTArrayDesignator "SubscriptExpression"]
[ICPPASTArrayDesignator "SubscriptExpression"]
[ICPPASTConstructorChainInitializer "InitializerValue"]
[ICPPASTConstructorInitializer "Expression"]
[ICPPASTDeleteExpression "Operand"]
[ICPPASTFunctionDeclarator "NoexceptExpression"]
[ICPPASTNewExpression "NewPlacement" "NewInitializer" "PlacementArguments"]
[ICPPASTPackExpansionExpression  "Pattern"]
[ICPPASTSimpleTypeConstructorExpression "InitialValue"]
[ICPPASTTemplatedTypeTemplateParameter "DefaultValue"]
[ICPPASTTypenameExpression "InitialValue"]
[IGCCASTArrayRangeDesignator "RangeFloor" "RangeCeiling"]
[IGCCASTSimpleDeclSpecifier "TypeofExpression"]
[IGNUASTGotoStatement "LabelNameExpression"]
[IGPPASTSimpleDeclSpecifier "TypeofExpression"]
[IASTFunctionCallExpression -maybe-set-args!]
[IASTExpressionList         -maybe-set-expr-list!]
 ])

(s/defn -replace-identifier!
  "If this node is capable of causing syntax ambiguities,
   try replacing parts of it to observe the ambiguity"
  [node :- IASTNode replacements :- {s/Str IASTNode}]
  (->> expression-sites
       (some
        (fn [[type & methods]]
          (when (instance? type node)
            (if (instance? String (first methods))
              (apply -maybe-set-operands! node replacements methods)
              ((first methods) node replacements)))))))

(s/defn parse-macro
  [macro-exp :- IASTPreprocessorMacroExpansion]
  (let [macro-def (->> macro-exp .getMacroDefinition)
        body-str  (macro-body-str macro-exp)]
    {:def macro-def
     :exp macro-exp
     :params-str (->> macro-def .getParameters (map (memfn getParameter)))
     :args-str   (->> macro-exp expansion-args-str)
     :args-tree  (->> macro-exp expansion-args-tree)
     :body-str   body-str
     :body-tree  (parse-frag body-str)}))

(s/defn macro-replace-arg-str
  [macro-exp :- IASTPreprocessorMacroExpansion]
  (let [mac        (parse-macro macro-exp)
        param-args (zipmap (:params-str mac) (:args-str mac))]
    (->> mac :body-str (id-replace-map param-args) parse-frag)))

(defn paren-wrap
  [node]
  (CPPASTUnaryExpression. IASTUnaryExpression/op_bracketedPrimary (.copy node)))

(s/defn macro-replace-arg-tree
  [macro-exp :- IASTPreprocessorMacroExpansion]
  (let [mac        (parse-macro macro-exp)
        param-args (zipmap (:params-str mac) (:args-tree mac))
        new-body   (->> mac :body-tree .copy)
        ;; Add top-level parens so we can modify the root
        [body-handle body-getter] (if (instance? IASTExpression new-body) [(paren-wrap new-body) child] [new-body identity])
        name-sites (->> body-handle (filter-tree id-name) set)
        ]

    (when (not (or
           ;; don't bother trying to parse macros with nested macros
           ;; note - we could do this test at the beginning of the function
           ;; to save some computation
           (and
            (->> macro-exp .getNestedMacroReferences empty? not)
            (do (comment (println (str "Won't expand nested macros in: " (filename (:exp mac)) ":" (start-line (:exp mac)) " - " (write-tree (body-getter body-handle)))))
                    true))

           ;; replace all matching arguments
           (->> body-handle (filter-tree #(-replace-identifier! % param-args))
                (remove nil?) doall empty?)

           ;; if any un-matched args remain, bail out
           ;; TODO these are the false-negatives
           (and
            (->> body-handle (filter-tree #((-> mac :params-str set) (id-name %))) (exists? name-sites))
            (do (println (str "Couldn't expand: " (filename (:exp mac)) ":" (start-line (:exp mac)) " - " (write-tree (body-getter body-handle))))
                    true))
           ))
      (body-getter body-handle))))

(require '[atom-finder.tree-diff :refer :all])
(s/defn inner-macro-operator-atom? :- (s/maybe IASTNode)
  "Does this expansion lead to a confusion AST tree outside of itself"
  [exp :- IASTPreprocessorMacroExpansion]
  (when-let* [_  (not (substituting-macro? exp))
              _  (instance? IASTPreprocessorFunctionStyleMacroDefinition (.getMacroDefinition exp))
              replaced-str  (macro-replace-arg-str  exp)
              replaced-tree (macro-replace-arg-tree exp)
              ;replaced-str  (pap print-tree (macro-replace-arg-str  exp))
              ;replaced-tree (pap print-tree (macro-replace-arg-tree exp))
              _  (not (atom-finder.tree-diff/tree=by (juxt class expr-operator)
                       replaced-str
                       replaced-tree))
              ]
    (->> exp location-parent greatest-trivial-parent)))

(s/defn macro-inner-precedence-finder
  [root :- IASTTranslationUnit]
  (->> root .getMacroExpansions (keep inner-macro-operator-atom?)))

(s/defn macro-operator-precedence-atom?
  "Does this expansion lead to a confusion"
  [node]
  ((some-fn inner-macro-operator-atom? outer-macro-operator-atom?) node))

(s/defn macro-operator-precedence-finder
  [root :- IASTTranslationUnit]
  (->> root .getMacroExpansions (keep macro-operator-precedence-atom?)))

(in-ns 'atom-finder.classifier)
(import '(org.eclipse.cdt.core.dom.ast IASTNode IASTName IASTIdExpression IASTBinaryExpression IASTUnaryExpression IASTExpressionStatement IASTPreprocessorFunctionStyleMacroDefinition IASTDoStatement IASTLiteralExpression IASTPreprocessorMacroExpansion cpp.ICPPASTTemplateId IASTCastExpression IASTFunctionCallExpression IASTEqualsInitializer IASTIfStatement IASTWhileStatement IASTForStatement IASTDoStatement IASTArraySubscriptExpression IASTExpressionList IASTFieldReference
IASTArrayModifier IASTBinaryExpression IASTCaseStatement IASTCastExpression IASTConditionalExpression IASTDoStatement IASTEnumerationSpecifier IASTExpressionStatement IASTFieldDeclarator IASTFieldReference IASTForStatement IASTFunctionCallExpression IASTIfStatement IASTInitializerExpression IASTReturnStatement IASTSimpleDeclSpecifier IASTSwitchStatement IASTUnaryExpression IASTWhileStatement IASTProblem)
        '(org.eclipse.cdt.core.dom.ast.cpp ICPPASTArrayDesignator ICPPASTConstructorChainInitializer ICPPASTConstructorInitializer ICPPASTDeleteExpression ICPPASTFunctionDeclarator ICPPASTNewExpression ICPPASTPackExpansionExpression ICPPASTSimpleTypeConstructorExpression ICPPASTTemplatedTypeTemplateParameter ICPPASTTypenameExpression)
        '(org.eclipse.cdt.core.dom.ast.gnu cpp.IGPPASTSimpleDeclSpecifier c.IGCCASTArrayRangeDesignator c.IGCCASTSimpleDeclSpecifier IGNUASTGotoStatement )
        '(org.eclipse.cdt.core.dom.ast.c ICASTArrayDesignator)
        '(org.eclipse.cdt.internal.core.parser.scanner ASTFunctionStyleMacroDefinition ASTMacroDefinition)
        '(org.eclipse.cdt.internal.core.dom.parser.cpp CPPASTUnaryExpression CPPASTExpressionList )
        )

(s/defn valid-node?
  [node :- (s/maybe IASTNode)]
  (and node (not (instance? IASTProblem node))))

;;https://stackoverflow.com/questions/9568050/in-clojure-how-to-write-a-function-that-applies-several-string-replacements
(s/defn replace-map
  "given an input string and a hash-map, returns a new string with all
   keys in map found in input replaced with the value of the key"
  [replacements :- {s/Str s/Str} target :- s/Str]
  (reduce (fn [target [pattern replacement]]
            (str/replace target (re-pattern pattern) replacement))
          target replacements))

(s/defn id-replace-map
  "replace identifiers"
  [replacements :- {s/Str s/Str} target :- s/Str]
  (replace-map
   (->> replacements
        ;; don't match ids inside other ids
        (map-keys #(str "(?<!\\w)" (java.util.regex.Pattern/quote %) "(?!\\w)"))
        (map-values str/re-quote-replacement))
   target))

(extend-protocol atom-finder.util/ASTTree clojure.lang.ISeq
  (ast-node [lst] (first lst))
  (children [lst] (rest lst)))

(extend-protocol atom-finder.util/ASTTree nil
  (ast-node [lst] nil)
  (children [lst] '()))

(defn seq-tree
  "A tree of nested lists that represents the AST"
  [node]
  (cons node (map seq-tree (children node))))

(defn prune-seq-tree
  "Form new leaves at a given predicate"
  [f any-tree]
  (let [[x & xs] (if (seqable? any-tree) any-tree (seq-tree any-tree))]
    (cons x
          (->> xs (map #(if (f (ast-node %1)) '() %1))  (map #(if (= '() %1) '() (prune-seq-tree f %1)))))))

(defn prune-terminals
  [tree]
  (prune-seq-tree (fn [node] (any-pred? #(instance? % node) [IASTIdExpression IASTLiteralExpression])) tree))

(s/defn expansion-container
  "The AST node that fully encloses a macro expansion"
  [expansion :- IASTPreprocessorMacroExpansion]
    (some->> expansion location-parent greatest-trivial-parent))

(s/defn expansion-parent
  "The parent of the AST node that fully encloses a macro expansion"
  [expansion :- IASTPreprocessorMacroExpansion]
    (some->> expansion expansion-container parent parent))

;; the template is being parsed as greater-than + int + less-than, just
;; ignore these some-how. maybe by ignoring every template in the expanded
;; case, or every tree (greater, X, lessthan) tree in the un-expanded?
(s/defn template-misparse?
  "sometimes the parser screws up A<b>::c so check if that happened"
  [expanded :- IASTNode unexpanded :- ExprOperator]
  (and (->> unexpanded :name (#{:lessThan :greaterThan}))
       (->> expanded (filter-tree (partial instance? ICPPASTTemplateId)) empty? not)))

(defn parse-macro-def
  [macro-def]
  (let [[all name args body] (->> macro-def str (re-find #"^([^=(]*)(?:\(([^)]*)\))?=(.*)"))]
    {:name name
     :args (some-<>> args (str/split <> #",") (remove empty?))
     :body body}))

(s/defn macro-defs-by-name {s/Str IASTPreprocessorMacroDefinition}
  [root :- IASTTranslationUnit]
  (->> root .getMacroDefinitions (map (juxt #(-> % .getName str) identity)) (into {})))

;; This doesn't catch cases where Macros are redefined throughout the file
(s/defn macro-body-str
  "Expand the body of the macro defnition"
  [macro-exp :- IASTPreprocessorMacroExpansion]
  (->> macro-exp .getMacroDefinition parse-macro-def :body))

'((->> "
  #define N	x
  #define M(x)  N(x)
  int y = M();
" parse-source .getMacroExpansions first macro-body-str))

(s/defn substituting-macro?
  [exp :- IASTPreprocessorMacroExpansion]
  (->> exp macro-body-str (re-find #"#")))

(s/defn outer-macro-operator-atom? :- (s/maybe IASTNode)
  "Does this expansion lead to a confusion AST tree outside of itself"
  [expansion :- IASTPreprocessorMacroExpansion]
  (let [exp-node (expansion-parent expansion)
        expanded   (some->> exp-node expr-operator)
        unexpanded (some->> exp-node write-tree parse-frag expr-operator)]
    (when (and (not (substituting-macro? expansion))
               expanded unexpanded
               (not= expanded unexpanded)
               (not (template-misparse? exp-node unexpanded)))
      exp-node)))

(s/defn macro-outer-precedence-finder
  [root :- IASTTranslationUnit]
  (->> root .getMacroExpansions (keep outer-macro-operator-atom?)))

(s/defn expansion-args-tree
  "Take the arguments to a macro and parse them into ASTs"
  [exp :- IASTPreprocessorMacroExpansion]
  ;; todo, is there a function that does this regex already
  (let [arg-str  (some->> exp str (re-find #"(?s)\w+\((.*)\)") second)
        arg-expr (some->> arg-str parse-frag)]
    (when arg-expr
      (cond
        (= arg-str "")
          []
        (instance? IASTExpressionList arg-expr)   ;; multiple args
          (children arg-expr)
        (instance? IASTProblem arg-expr) ;; statements as args?
          (let [parsed-args (some-<>> arg-str (str/split <> #",") (map parse-frag))]
            (when (every? valid-node? parsed-args)
              parsed-args))
        :else [arg-expr]                          ;; single arg
        ))))

(s/defn expansion-args-str :- [s/Str]
  "Extract the code in the arguments to a macro"
  [exp :- IASTPreprocessorMacroExpansion]
  (->> exp expansion-args-tree (map write-tree)))

(s/defn id-name
  [node :- IASTNode]
  (cond (instance? IASTIdExpression node) (.getName node)
        (instance? IASTName node) node
        :else nil))

(s/defn -maybe-set-value!
  [getter setter node replacements]
  (when-let* [operand     (getter node)
              name        (id-name operand)
              replacement (-> name str replacements)
              _           (instance? IASTExpression replacement)
              ]
       (doto node
         (setter (.copy (cond (instance? IASTIdExpression operand) replacement
                              (instance? IASTName operand) (.getName replacement)))))))

(s/defn -maybe-set-args!
  [node :- IASTFunctionCallExpression replacements]
  (let [args (.getArguments node)]
    (->> args
         count
         range
         (map (fn [idx] (-maybe-set-value!
                         (fn [_] (nth args idx))
                         (fn [_ new-child] (aset args idx new-child))
                         node replacements)))
         dorun)

    (doto node (.setArguments args))))

(s/defn -maybe-set-expr-list!
  [node :- CPPASTExpressionList replacements]
  (doseq [expr (.getExpressions node)]
    (-maybe-set-value!
     (fn [node] expr)
     (fn [_ new-child] (.replace node expr new-child))
     node replacements))
  node)

(s/defn -maybe-set-operand!
  "Take an identifier, and replace it with its full tree"
  [method node replacements]
  (-maybe-set-value! #(call-method % (str 'get method))
                     #(call-method %1 (str 'set method) %2)
                     node replacements))

(s/defn -maybe-set-operands!
  [node replacements & methods]
  (->> methods
       (map #(-maybe-set-operand! %1 node replacements))
       doall
       (some identity)))
(def expression-sites [
[IASTArrayModifier "ConstantExpression"]
[IASTArraySubscriptExpression "Argument" "ArrayExpression"]
[IASTBinaryExpression "Operand1" "Operand2"]
[IASTCaseStatement "Expression"]
[IASTCastExpression "Operand"]
[IASTConditionalExpression "LogicalConditionExpression" "PositiveResultExpression" "NegativeResultExpression"]
[IASTDoStatement "Condition"]
[IASTEnumerationSpecifier "Value"]
[IASTEqualsInitializer "InitializerClause"]
[IASTExpressionStatement "Expression"]
[IASTFieldDeclarator "BitFieldSize"]
[IASTFieldReference "FieldOwner" "FieldName"]
[IASTForStatement "ConditionExpression" "IterationExpression"]
[IASTFunctionCallExpression "FunctionNameExpression"]
[IASTIfStatement "ConditionExpression"]
[IASTInitializerExpression "Expression"]
[IASTReturnStatement "ReturnValue"]
[IASTSimpleDeclSpecifier "DeclTypeExpression"]
[IASTSwitchStatement "ControllerExpression"]
[IASTUnaryExpression "Operand"]
[IASTWhileStatement "Condition"]
[ICASTArrayDesignator "SubscriptExpression"]
[ICPPASTArrayDesignator "SubscriptExpression"]
[ICPPASTConstructorChainInitializer "InitializerValue"]
[ICPPASTConstructorInitializer "Expression"]
[ICPPASTDeleteExpression "Operand"]
[ICPPASTFunctionDeclarator "NoexceptExpression"]
[ICPPASTNewExpression "NewPlacement" "NewInitializer" "PlacementArguments"]
[ICPPASTPackExpansionExpression  "Pattern"]
[ICPPASTSimpleTypeConstructorExpression "InitialValue"]
[ICPPASTTemplatedTypeTemplateParameter "DefaultValue"]
[ICPPASTTypenameExpression "InitialValue"]
[IGCCASTArrayRangeDesignator "RangeFloor" "RangeCeiling"]
[IGCCASTSimpleDeclSpecifier "TypeofExpression"]
[IGNUASTGotoStatement "LabelNameExpression"]
[IGPPASTSimpleDeclSpecifier "TypeofExpression"]
[IASTFunctionCallExpression -maybe-set-args!]
[IASTExpressionList         -maybe-set-expr-list!]
 ])

(s/defn -replace-identifier!
  "If this node is capable of causing syntax ambiguities,
   try replacing parts of it to observe the ambiguity"
  [node :- IASTNode replacements :- {s/Str IASTNode}]
  (->> expression-sites
       (some
        (fn [[type & methods]]
          (when (instance? type node)
            (if (instance? String (first methods))
              (apply -maybe-set-operands! node replacements methods)
              ((first methods) node replacements)))))))

(s/defn parse-macro
  [macro-exp :- IASTPreprocessorMacroExpansion]
  (let [macro-def (->> macro-exp .getMacroDefinition)
        body-str  (macro-body-str macro-exp)]
    {:def macro-def
     :exp macro-exp
     :params-str (->> macro-def .getParameters (map (memfn getParameter)))
     :args-str   (->> macro-exp expansion-args-str)
     :args-tree  (->> macro-exp expansion-args-tree)
     :body-str   body-str
     :body-tree  (parse-frag body-str)}))

(s/defn macro-replace-arg-str
  [macro-exp :- IASTPreprocessorMacroExpansion]
  (let [mac        (parse-macro macro-exp)
        param-args (zipmap (:params-str mac) (:args-str mac))]
    (->> mac :body-str (id-replace-map param-args) parse-frag)))

(defn paren-wrap
  [node]
  (CPPASTUnaryExpression. IASTUnaryExpression/op_bracketedPrimary (.copy node)))

(s/defn macro-replace-arg-tree
  [macro-exp :- IASTPreprocessorMacroExpansion]
  (let [mac        (parse-macro macro-exp)
        param-args (zipmap (:params-str mac) (:args-tree mac))
        new-body   (->> mac :body-tree .copy)
        ;; Add top-level parens so we can modify the root
        [body-handle body-getter] (if (instance? IASTExpression new-body) [(paren-wrap new-body) child] [new-body identity])
        name-sites (->> body-handle (filter-tree id-name) set)
        ]

    (when (not (or
           ;; don't bother trying to parse macros with nested macros
           ;; note - we could do this test at the beginning of the function
           ;; to save some computation
           (and
            (->> macro-exp .getNestedMacroReferences empty? not)
            (do (comment (println (str "Won't expand nested macros in: " (filename (:exp mac)) ":" (start-line (:exp mac)) " - " (write-tree (body-getter body-handle)))))
                    true))

           ;; replace all matching arguments
           (->> body-handle (filter-tree #(-replace-identifier! % param-args))
                (remove nil?) doall empty?)

           ;; if any un-matched args remain, bail out
           ;; TODO these are the false-negatives
           (and
            (->> body-handle (filter-tree #((-> mac :params-str set) (id-name %))) (exists? name-sites))
            (do (println (str "Couldn't expand: " (filename (:exp mac)) ":" (start-line (:exp mac)) " - " (write-tree (body-getter body-handle))))
                    true))
           ))
      (body-getter body-handle))))

(require '[atom-finder.tree-diff :refer :all])
(s/defn inner-macro-operator-atom? :- (s/maybe IASTNode)
  "Does this expansion lead to a confusion AST tree outside of itself"
  [exp :- IASTPreprocessorMacroExpansion]
  (when-let* [_  (not (substituting-macro? exp))
              _  (instance? IASTPreprocessorFunctionStyleMacroDefinition (.getMacroDefinition exp))
              replaced-str  (macro-replace-arg-str  exp)
              replaced-tree (macro-replace-arg-tree exp)
              ;replaced-str  (pap print-tree (macro-replace-arg-str  exp))
              ;replaced-tree (pap print-tree (macro-replace-arg-tree exp))
              _  (not (atom-finder.tree-diff/tree=by (juxt class expr-operator)
                       replaced-str
                       replaced-tree))
              ]
    (->> exp location-parent greatest-trivial-parent)))

(s/defn macro-inner-precedence-finder
  [root :- IASTTranslationUnit]
  (->> root .getMacroExpansions (keep inner-macro-operator-atom?)))

(s/defn macro-operator-precedence-atom?
  "Does this expansion lead to a confusion"
  [node]
  ((some-fn inner-macro-operator-atom? outer-macro-operator-atom?) node))

(s/defn macro-operator-precedence-finder
  [node :- IASTNode] ; IASTTranslationUnit]
  (->> node root-ancestor .getMacroExpansions (keep macro-operator-precedence-atom?)))

Allow macro-operator-precedence to work on non-root nodes


(ns chocolatier.engine.components.controllable
  (:require [chocolatier.utils.logging :as log]
            [chocolatier.engine.ces :as ces]
            [chocolatier.engine.systems.events :as ev]))

(defn include-input-state
  "State parsing function. Returns a vector of input-state, component-state
   component-id and entity-id"
  [state component-id entity-id]
  {:input-state (get-in state [:game :input])})

(def move-rate 4)

(def keycode->interaction
  {:W {:action :walk :direction :up :offset-x 0 :offset-y (* 1 move-rate)}
   :S {:action :walk :direction :down :offset-x 0 :offset-y (* -1 move-rate)}
   :A {:action :walk :direction :left :offset-x (* 1 move-rate) :offset-y 0}
   :D {:action :walk :direction :right :offset-x (* -1 move-rate) :offset-y 0}
   ;; TODO this causes a compiler error with optimizations advanced
   (keyword "¿") {:action :attack}
   :B {:action :replay}})

;; FIX The output of the interaction hashmap is non-deterministic
;; because it is iterating through a hashmap where ordering is not
;; guaranteed. Need to iterate through only the accepted keycodes and
;; check if the input-state shows the key is "on". That way order is
;; controlled by the caller
(defn input->interaction
  "Returns a hashmap of the intended interactions based on user input.
   There can be only one direction and action, last pressed key wins.
   Keys:
   - offset-x/y: movement x/y in pixels
   - direction: direction the player is facing
   - action: the action based on the input"
  [input-state]
  (loop [out {}, input-seq (seq input-state)]
    (if (seq input-seq)
      (let [[k v] (first input-seq)
            out (if-let [interaction (k keycode->interaction)]
                  (into out interaction)
                  out)]
        (recur out (rest input-seq)))
      out)))

(defn react-to-input
  [entity-id component-state {:keys [input-state]}]
  (let [interaction-state (input->interaction input-state)]
    ;; If the old interaction state is the same as the new
    ;; interaction or there is no interaction then no need to do
    ;; anything
    (if (= component-state interaction-state)
      component-state
      (let [{:keys [action direction offset-x offset-y]} interaction-state
            prev-direction (or (:direction component-state) :down)
            ;; Default to standing
            action (if-not action :stand action)
            ;; Default to prev direction
            direction (if-not direction prev-direction direction)
            events (cond->
                       []
                     (= action :replay)
                     (conj (ev/mk-event {:replay? true} [:replay]))
                     (= action :attack)
                     (conj (ev/mk-event {:action action :direction direction}
                                        [:action entity-id]))
                     (= action :walk)
                     (into [(ev/mk-event {:offset-x offset-x :offset-y offset-y}
                                         [:move-change entity-id])
                            (ev/mk-event {:action action :direction direction}
                                         [:action entity-id])])
                     (= action :stand)
                     (into [(ev/mk-event {:offset-x 0 :offset-y 0}
                                         [:move-change entity-id])
                            (ev/mk-event {:action action :direction direction}
                                         [:action entity-id])]))
            updated-state {:action action
                           :direction direction
                           :offset-x offset-x
                           :offset-y offset-y}]
        (if (seq events)
          [updated-state events]
          updated-state)))))

(ns chocolatier.engine.components.controllable
  (:require [chocolatier.utils.logging :as log]
            [chocolatier.engine.ces :as ces]
            [chocolatier.engine.systems.events :as ev]))

(defn include-input-state
  "State parsing function. Returns a vector of input-state, component-state
   component-id and entity-id"
  [state component-id entity-id]
  {:input-state (get-in state [:game :input])})

(def move-rate 4)

(def keycode->interaction
  {:W {:action :walk :direction :up :offset-x 0 :offset-y (* 1 move-rate)}
   :S {:action :walk :direction :down :offset-x 0 :offset-y (* -1 move-rate)}
   :A {:action :walk :direction :left :offset-x (* 1 move-rate) :offset-y 0}
   :D {:action :walk :direction :right :offset-x (* -1 move-rate) :offset-y 0}
   (keyword "¿") {:action :attack}
   :B {:action :replay}})

(defn comp-interaction
  [v1 v2]
  (if (and (number? v1) (number? v2))
    (+ v1 v2)
    v2))

;; FIX The output of the interaction hashmap is non-deterministic
;; because it is iterating through a hashmap where ordering is not
;; guaranteed. Need to iterate through only the accepted keycodes and
;; check if the input-state shows the key is "on". That way order is
;; controlled by the caller
(defn input->interaction
  "Returns a hashmap of the intended interactions based on user input.
   There can be only one direction and action, last pressed key wins.
   Keys:
   - offset-x/y: movement x/y in pixels
   - direction: direction the player is facing
   - action: the action based on the input"
  [input-state]
  (loop [out {}, input-seq (seq input-state)]
    (if (seq input-seq)
      (let [[k v] (first input-seq)
            out (if-let [interaction (k keycode->interaction)]
                  (merge-with comp-interaction out interaction)
                  out)]
        (recur out (rest input-seq)))
      out)))

(defn react-to-input
  [entity-id component-state {:keys [input-state]}]
  (let [interaction-state (input->interaction input-state)]
    ;; If the old interaction state is the same as the new
    ;; interaction or there is no interaction then no need to do
    ;; anything
    (if (= component-state interaction-state)
      component-state
      (let [{:keys [action direction offset-x offset-y]} interaction-state
            prev-direction (or (:direction component-state) :down)
            ;; Default to standing
            action (if-not action :stand action)
            ;; Default to prev direction
            direction (if-not direction prev-direction direction)
            events (cond->
                       []
                     (= action :replay)
                     (conj (ev/mk-event {:replay? true} [:replay]))
                     (= action :attack)
                     (conj (ev/mk-event {:action action :direction direction}
                                        [:action entity-id]))
                     (= action :walk)
                     (into [(ev/mk-event {:offset-x offset-x :offset-y offset-y}
                                         [:move-change entity-id])
                            (ev/mk-event {:action action :direction direction}
                                         [:action entity-id])])
                     (= action :stand)
                     (into [(ev/mk-event {:offset-x 0 :offset-y 0}
                                         [:move-change entity-id])
                            (ev/mk-event {:action action :direction direction}
                                         [:action entity-id])]))
            updated-state {:action action
                           :direction direction
                           :offset-x offset-x
                           :offset-y offset-y}]
        (if (seq events)
          [updated-state events]
          updated-state)))))

Enable diagonal player movement

Enable diagonal player movement


(ns game.macros)

(defmacro effect [& expr]
  `(fn ~['state 'side 'card 'targets]
     ~(let [actions (map #(if (#{:runner :corp} (second %))
                            (concat [(first %) 'state (second %)] (drop 2 %))
                            (concat [(first %) 'state 'side] (rest %)))
                         expr)]
        `(let ~['runner '(:runner @state)
                'corp '(:corp @state)
                'corp-reg '(get-in @state [:corp :register])
                'runner-reg '(get-in @state [:runner :register])
                'current-ice '(when-let [run (:run @state)]
                                (when (> (or (:position run) 0) 0) ((:ices run) (dec (:position run)))))
                'target '(first targets)]
           ~@actions))))

(defmacro req [& expr]
  `(fn ~['state 'side 'card 'targets]
     (let ~['runner '(:runner @state)
            'corp '(:corp @state)
            'run '(:run @state)
            'current-ice '(when (and run (> (or (:position run) 0) 0)) ((:ices run) (dec (:position run))))
            'corp-reg '(get-in @state [:corp :register])
            'runner-reg '(get-in @state [:runner :register])
            'target '(first targets)
            'installed '(#{:rig :servers} (first (:zone card)))
            'remotes '(map #(str "Server " %) (range (count (get-in corp [:servers :remote]))))
            'servers '(concat ["HQ" "R&D" "Archives"] remotes)
            'tagged '(or (> (:tagged runner) 0) (> (:tag runner) 0))
            'this-server '(let [s (-> card :zone rest butlast)
                                r (:server run)]
                            (and (= (first r) (first s))
                                 (= (last r) (last s))))]
        ~@expr)))

(defmacro msg [& expr]
  `(fn ~['state 'side 'card 'targets]
     (let ~['runner '(:runner @state)
            'corp '(:corp @state)
            'corp-reg '(get-in @state [:corp :register])
            'runner-reg '(get-in @state [:runner :register])
            'run '(:run @state)
            'current-ice '(when (and run (> (or (:position run) 0) 0)) ((:ices run) (dec (:position run))))
            'target '(first targets)]
       (str ~@expr))))

(ns game.macros)

(defmacro effect [& expr]
  `(fn ~['state 'side 'card 'targets]
     ~(let [actions (map #(if (#{:runner :corp} (second %))
                            (concat [(first %) 'state (second %)] (drop 2 %))
                            (concat [(first %) 'state 'side] (rest %)))
                         expr)]
        `(let ~['runner '(:runner @state)
                'corp '(:corp @state)
                'corp-reg '(get-in @state [:corp :register])
                'runner-reg '(get-in @state [:runner :register])
                'current-ice '(when-let [run (:run @state)]
                                (when (> (or (:position run) 0) 0) ((:ices run) (dec (:position run)))))
                'target '(first targets)]
           ~@actions))))

(defmacro req [& expr]
  `(fn ~['state 'side 'card 'targets]
     (let ~['runner '(:runner @state)
            'corp '(:corp @state)
            'run '(:run @state)
            'current-ice '(when (and run (> (or (:position run) 0) 0)) ((:ices run) (dec (:position run))))
            'corp-reg '(get-in @state [:corp :register])
            'runner-reg '(get-in @state [:runner :register])
            'target '(first targets)
            'installed '(#{:rig :servers} (first (:zone card)))
            'remotes '(map #(str "Server " %) (range (count (get-in corp [:servers :remote]))))
            'servers '(concat ["HQ" "R&D" "Archives"] remotes)
            'tagged '(or (> (:tagged runner) 0) (> (:tag runner) 0))
            'this-server '(let [s (-> card :zone rest butlast)
                                r (:server run)]
                            (and (= (first r) (first s))
                                 (= (last r) (last s))))]
        ~@expr)))

(defmacro msg [& expr]
  `(fn ~['state 'side 'card 'targets]
     (let ~['runner '(:runner @state)
            'corp '(:corp @state)
            'corp-reg '(get-in @state [:corp :register])
            'runner-reg '(get-in @state [:runner :register])
            'run '(:run @state)
            'current-ice '(when (and run (> (or (:position run) 0) 0)) ((:ices run) (dec (:position run))))
            'target '(first targets)
            'tagged '(or (> (:tagged runner) 0) (> (:tag runner) 0))]
       (str ~@expr))))

add tagged to let in msg macro (for reality threedee)