(ns old
  (:require [clojure.core.match :refer [match]]
            [clojure.pprint :as pprint]
            [clojure.set :as set]
            [clojure.spec.alpha :as s]
            [clojure.walk]
            [spec-dict.main :refer [dict]]))

(defmacro todo
  ([] `(throw (ex-info "todo" {})))
  ([fmt & xs]
   `(throw (ex-info (format (str "todo: " ~fmt) ~@xs)
                    {}))))

(def primitives
  '#{let let-syntax letrec lambda syntax-rules if define
     define-syntax begin})

(def builtins
  '#{+ * / - car cdr write display newline cons list})

(s/def ::binding
  #(match %
     [:lexical sym uniq] (and (symbol? sym) (symbol? uniq))
     [:global sym] (symbol? sym)))

(s/def ::pattern
  (s/or :wildcard #{'_}
        :var (s/and symbol? (complement #{'... '_}))
        :lit ::literal
        :list (s/and seq?
                     (s/cat :leading (s/* ::pattern)
                            :rest (s/? (s/cat :ellipsis #{'...}
                                              :trailing (s/* ::pattern))))
                     (s/conformer
                      (fn [pat]
                        (if-some [{:keys [ellipsis trailing]} (:rest pat)]
                          (let [{:keys [leading]} pat]
                            (if-some [variadic (last leading)]
                              {:leading (vec (butlast leading))
                               :ellipsis variadic
                               :trailing trailing}
                              ::s/invalid))
                          pat))))))

(s/def ::literal (some-fn string? boolean? number? char?))

(defn literal? [x]
  (s/valid? ::literal x))

(s/def ::datum any?)

(declare variable?)

(s/def ::template
  (s/or :var ::variable
        :lit ::literal
        :list (s/and (s/* ::template-element) sequential?)))

(s/def ::template-element
  (s/& (s/cat :template ::template :ellipsis (s/? #{'...}))
       (s/conformer
          (fn [{:keys [ellipsis template]}]
            (if ellipsis
              [:ellipsis template]
              template)))))

(s/def ::rule
  (s/and sequential?
         (s/cat :pattern ::pattern
                :template ::template)))

;; cf. `::prim-syntax-rules`
(s/def ::transformer
  (dict {:rules (s/coll-of ::rule :kind sequential?)}
        ^:opt {:keywords (s/coll-of symbol?)}))

(s/def ::denotation
  #(match %
     [:var] true
     [:primitive p] (primitives p)
     ;; 나쁜
     [:macro trans] (contains? trans :rules)
     [:syntax datum] true))

(s/def ::environment
  (s/map-of ::binding ::denotation))

(s/def ::scope symbol?)

(s/def ::scope-set (s/coll-of ::scope :kind set?))

;; this is an inefficient representation. since we often want to
;; compute the submap of entries with a symbol 'x' but any scope, it
;; would be best to 'curry' the table, as Symbol → Scopes →
;; Binding. however, this is a bit more error-prone and cumbersome for
;; a prototype.
(s/def ::symtable
  (s/map-of (s/tuple symbol? (s/coll-of ::scope :kind set?))
            ::binding))

(s/def ::formals
  (s/coll-of symbol? :kind sequential?))

(s/def ::body
  (s/+ any?))

(declare destructure-variable)

(defprotocol IVariable
  (variable-symbol [this])
  (variable-scopes [this]))

(deftype Variable [symbol scopes]
  Object
  (equals [x y]
    (if-some [[y-symbol y-scopes] (destructure-variable y)]
      (and (.equals symbol y-symbol)
           (.equals scopes y-scopes))
      false))
  IVariable
  (variable-symbol [this] symbol)
  (variable-scopes [this] scopes))

(def ^:dynamic *print-variable-scopes* true)

;; does not respect `*print-dup*` lol
(defmethod print-method Variable [this writer]
  (binding [*out* writer]
    (if *print-variable-scopes*
      (pr [(variable-symbol this) (variable-scopes this)])
      (pr (variable-symbol this)))))

(defmethod clojure.pprint/simple-dispatch old.Variable [x]
  (clojure.pprint/simple-dispatch
   (if *print-variable-scopes*
     [(variable-symbol x) (variable-scopes x)]
     (variable-symbol x))))

(s/def ::variable
  (s/conformer
   (fn [x]
     (match x
       (_ :guard symbol?) (->Variable x nil)
       (_ :guard #(instance? Variable %))
       (if (symbol? (variable-symbol x))
         (let [r (s/conform ::scope-set (variable-scopes x))]
           (if (s/invalid? r)
             ::s/invalid
             (->Variable (variable-symbol x) (variable-scopes x))))
         ::s/invalid)
       [sym scopes] (let [r (s/conform (s/nilable ::scope-set) scopes)]
                      (if (and (symbol? sym) (not (s/invalid? r)))
                        (->Variable sym r)
                        ::s/invalid))
       :else ::s/invalid))))

(defn variable? [x]
  (s/valid? ::variable x))

(defn normalise-variale [v]
  (let [r (s/conform ::variable v)]
    (when-not (s/invalid? r)
      r)))

(defn destructure-variable [v]
  (let [r (s/conform ::variable v)]
    (when-not (s/invalid? r)
      [(variable-symbol r) (variable-scopes r)])))

#_
(defn variable-scopes [v]
  (when-some [[_ scopes] (destructure-variable v)]
    scopes))

#_
(defn variable-symbol [v]
  (when-some [[s _] (destructure-variable v)]
    s))

(defn offer-scopes
  "variable v는 안 resolve되면 v와 scopes는 붙음."
  [v scopes]
  (let [[sym existing-scopes] (destructure-variable v)]
    (->Variable sym (or existing-scopes scopes))))

(s/def ::prim-lambda
  (s/cat :keyword ::variable
         :formals ::formals
         :body ::body))

(s/def ::prim-let
  (s/cat :keyword ::variable
         :bindings (s/coll-of #(and (sequential? %)
                                    (= 2 (count %))
                                    (symbol? (first %)))
                              :kind sequential?)
         :body ::body))

(s/def ::prim-let-syntax ::prim-let)

;; cf. `::transformer`
(s/def ::prim-syntax-rules
  (s/and seq? (s/cat :keyword ::variable
                     :keywords (s/coll-of symbol?)
                     :rules (s/* ::rule))))

(s/def ::prim-if
  (s/and seq? (s/cat :keyword ::variable
                     :condition ::datum
                     :consequent ::datum
                     :alternative (s/? ::datum))))

(s/def ::prim-begin
  (s/and seq? (s/cat :keyword ::variable
                     :body (s/+ ::datum))))



(defn symtable-for-env [env]
  (into (hash-map)
        (for [[[_ x] _] env]
          [[x #{}] [:global x]])))

(defmacro meta-syntax-rules [kws & body]
  `(s/conform ::prim-syntax-rules
              (list 'syntax-rules '~kws
                    ~@(map (fn [x] `(quote ~x)) body))))

(defn define-global [env-ref symtable-ref sym denot]
  (swap! env-ref #(assoc % [:global sym] denot))
  (swap! symtable-ref #(assoc % [sym #{}] [:global sym])))

(declare expand)

(defn define-macro [env-ref symtable-ref sym trans]
  (let [trans (->> (expand trans @env-ref symtable-ref #{})
                   (s/conform ::prim-syntax-rules))]
    (assert (not (s/invalid? trans)))
    (define-global
      env-ref
      symtable-ref
      sym
      [:macro trans])))

(defn scheme-base []
  (let [env-ref (atom {})
        symtable-ref (atom {})]
    (define-global env-ref symtable-ref
      'λ [:primitive 'lambda])
    (doseq [p primitives]
      (define-global env-ref symtable-ref
        p [:primitive p]))
    (doseq [b builtins]
      (define-global env-ref symtable-ref
        b [:var]))
    (define-macro env-ref symtable-ref
      'and '(syntax-rules ()
             ((_) false)
             ((_ a) a)
             ((_ a b ...)
              (if a (and b ...) a))))
    (define-macro env-ref symtable-ref
      'when '(syntax-rules ()
              ((_ test body)
               (if test body))
              ((_ test body ...)
               (if test (begin body)))))
    {:env @env-ref
     :symtable @symtable-ref})
  #_(merge
     {[:global 'λ] [:primitive 'lambda]
      [:global 'and] [:macro
                      (meta-syntax-rules ()
                        ((_) false)
                        ((_ a) a)
                        ((_ a b ...)
                         (if a (and b ...) a)))]
      [:global 'when] [:macro
                       (meta-syntax-rules ()
                         ((_ test body)
                          (if test body))
                         ((_ test body ...)
                          (if test (begin body))))]}
     (into {} (for [p primitives]
                [[:global p] [:primitive p]]))
     (into {} (for [b builtins]
                [[:global b] [:var]]))))

(defn nearest [[sym scopes] ss]
  (when-some [xs (->> ss
                      (filter #(set/subset? % scopes))
                      (group-by count)
                      seq)]
    (second (apply max-key first xs))))

(defn- symtable-scopes
  "Gather the set of scope-sets associated with a given symbol."
  [symtable sym]
  (into #{} (for [[[x scopes] _] symtable
                  :when (= sym x)]
              scopes)))

(defn lookup [variable env symtable]
  (let [[sym scopes] (or (destructure-variable variable)
                         (throw (ex-info "not a var" {:var variable})))
        ss (symtable-scopes symtable sym)
        xs (nearest [sym scopes] ss)
        r (compare (count xs) 1)]
    (cond (neg? r) (throw (ex-info "undefined sym" {:sym sym}))
          (zero? r)
          (or (get env (or (get symtable [sym (first xs)])
                           (throw (ex-info "unreachable" {}))))
              (throw (ex-info "unreachable" {})))
          (pos? r) (throw (ex-info "ambiguous sym" {:sym sym})))))

(comment
  (let [{:keys [symtable env]} (scheme-base)
        st (atom symtable)]
    {:e (expand '(lambda (x y) x) env st #{})
     :st @st}))

(defmulti expand-primitive
  (fn [_datum prim-name _env _symtable-ref _scopes]
    prim-name))

(defn new-scope
  ([] (gensym "scope__"))
  ([prefix] (gensym (str "scope__" prefix))))

(defn bind-lexical [[sym scopes] denot symtable-ref]
  (let [bind [:lexical sym (gensym)]]
    (swap! symtable-ref #(assoc % [sym scopes] bind))
    {bind denot}))

(defn make-symtable [[sym scopes] bind]
  {[sym scopes] bind})



(defn- report-conflict [x y]
  (throw (ex-info "너무 정의합니다"
                  {:x x :y y})))

(defn- merge-unify-with
  ([f] {})
  ([f a] a)
  ([f a b] (and a b (merge-with f a b)))
  ([f a b & xs] (reduce #(merge-unify-with f %1 %2) (cons a (cons b xs)))))

(defn- merge-unify [& xs]
  (apply merge-unify-with report-conflict xs))

(defn- unify* [pattern datum]
  (match [pattern datum]
    [[:wildcard _] _] {}
    [[:var x] _] {x datum}
    
    [[:list {:leading leading
             :trailing nil
             :ellipsis ellipsis}]
     (_ :guard seq?)]
    (let [[leading-datum ellipsis-datum] (split-at (count leading) datum)]
      (merge-unify
       (apply merge-unify (map #(unify* %1 %2)
                               leading
                               leading-datum))
       (some->> ellipsis-datum
                (map #(some-> (unify* ellipsis %)
                              (update-vals list)))
                (apply merge-unify-with concat)
                (map (fn [[k v]]
                       [k [:ellipsis v]]))
                (into {}))))

    [[:list {:leading leading}]
     (_ :guard seq?)]
    (when (= (count datum)
             (count leading))
      (->> (map #(unify* %1 %2) leading datum)
           (apply merge-unify)))

    ;; no match
    :else nil))

(defn unify [pattern datum]
  (unify* (s/conform ::pattern pattern) datum))

(defn unification->env [unification symtable-ref scopes]
  (into {}
        (doall (for [[k v] unification]
                 (bind-lexical [k scopes] [:syntax v]
                               symtable-ref)))))

(defn unify-trans
  "`unify`로 모든 trans의 패턴은 datum을 맞음. datum으로 맞은 패턴은
  없으면 nil을 결과할 것입나다.

  걸과의 모습은 [rule unification]입니다. 여기서 rule이 최초 맞은
  trans의 rule이고, unification이 `unify`의 결과입니다."
  [trans datum]
  (some (fn [{:keys [pattern template]
              :as rule}]
          (when-some [unif (unify* pattern datum)]
            [rule unif]))
        (:rules trans)))

(defn transcribe [template env symtable scopes]
  (match template
    [:var x] (let [x* (offer-scopes x scopes)]
               (match (lookup x* env symtable)
                 [:syntax [:ellipsis fuckoffmanjustshadowit]] (todo "점점점")
                 [:syntax syn] syn
                 :else x*))
    [:ellipsis _] (todo "점점점")
    [:lit x] x
    [:list xs]
    (do (tap> xs)
        (map #(transcribe % env symtable scopes) xs))))

(defn resolve-template [template scopes]
  (clojure.walk/postwalk
   #(if (variable? %)
      (offer-scopes % scopes)
      %)
   template))


;;; expand

(declare expand)

(defmethod expand-primitive 'lambda
  [datum _ env symtable-ref scopes]
  (let [{:keys [formals body]} (s/conform ::prim-lambda datum)
        scopes* (conj scopes (new-scope))
        env* (apply merge env
                    (for [x formals]
                      (bind-lexical [x scopes*]
                                    [:var] symtable-ref)))]
    (concat (list 'lambda
                  (for [x formals]
                    (offer-scopes x scopes*)))
            (for [e body]
              (expand e env* symtable-ref scopes*)))))

(defmethod expand-primitive 'let
  [datum _ env symtable-ref scopes]
  (let [{:keys [bindings body]} (s/conform ::prim-let datum)
        scopes* (conj scopes (new-scope))
        env* (apply merge env
                    (for [[x _] bindings]
                      (bind-lexical [x scopes*]
                                    [:var] symtable-ref)))]
    (concat (list 'let
                  (for [[k v] bindings]
                    (list (offer-scopes k scopes*) v)))
            (for [e body]
              (expand e env* symtable-ref scopes*)))))

(defmethod expand-primitive 'let-syntax
  [datum _ env symtable-ref scopes]
  (let [{:keys [bindings body]} (s/conform ::prim-let-syntax datum)
        scopes* (conj scopes (new-scope))
        env* (apply merge env
                    (for [[x rhs] bindings]
                      (let [trans (->> (expand rhs env symtable-ref scopes)
                                       (s/conform ::prim-syntax-rules))]
                        (assert (not (s/invalid? trans)))
                        (bind-lexical
                         [x scopes*]
                         [:macro trans]
                         symtable-ref))))]
    (concat (list 'let-syntax bindings)
            (for [e body]
              (expand e env* symtable-ref scopes*)))))

(defmethod expand-primitive 'syntax-rules
  [datum _ env symtable-ref scopes]
  (assert (s/valid? ::prim-syntax-rules datum))
  (let [scopes* (conj scopes (new-scope))
        keywords (nth datum 1)
        rules (nthrest datum 2)]
    (concat (list 'syntax-rules
                  keywords)
            (for [[pattern template] rules]
              (list pattern (resolve-template template scopes*))))))

(defmethod expand-primitive 'if
  [datum _ env symtable-ref scopes]
  (let [{:keys [condition consequent alternative]}
        (s/conform ::prim-if datum)
        ex #(expand % env symtable-ref scopes)]
    (concat (list 'if (ex condition)
                  (ex consequent))
            (some-> alternative ex))))

(defmethod expand-primitive 'begin
  [datum _ env symtable-ref scopes]
  (let [{:keys [body]} (s/conform ::prim-begin datum)]
    (cons 'begin (map #(expand % env symtable-ref scopes) body))))

(comment
  (let [env (:env scheme-base-env)
        [_ trans] (get env [:global 'and])
        datum '(and 12 34)
        symtable-ref (atom (symtable-for-env env))
        scopes #{1}]
    (expand-macro
     trans datum
     env symtable-ref scopes)))

(defn expand-macro [trans datum env symtable-ref scopes]
  (let [[rule unif]
        (-> (unify-trans trans datum)
            (or (throw
                 (ex-info
                  "데이텀을 맞은 패턴은 찾을 수 없었습니다"
                  {:trans trans :datum datum}))))
        scopes* (conj scopes (new-scope))
        env* (merge env (unification->env unif symtable-ref scopes*))]
    (expand (transcribe (:template rule) env* @symtable-ref scopes*)
            env ;; 아마도 `env*`를 써야 되고 `env`를 안 써야 된가?
            symtable-ref
            scopes)))

(defn expand
  ([datum]
   (let [{:keys [env symtable]} (scheme-base)]
     (expand
      datum env (atom symtable) #{})))
  ([datum env symtable-ref scopes]
   (match datum
     ;; literals
     (x :guard literal?) x
     ;; variables (both resolved and unresolved)
     (x :guard variable?)
     (let [x* (offer-scopes x scopes)]
       (lookup x* env @symtable-ref) ; throw if unbound
       x*)

     ;; lists
     ([f & xs] :seq)
     (or (when-let [v (and (variable? f)
                           (offer-scopes f scopes))]
           (match (lookup v env @symtable-ref)
             [:primitive prim] (expand-primitive
                                datum prim env symtable-ref scopes)
             [:macro trans] (expand-macro trans datum env symtable-ref scopes)
             [:var] nil))
         (cons (expand f env symtable-ref scopes)
               (map #(expand % env symtable-ref scopes) xs))))))



(defn regensym
  "Renumber the gensyms created by `new-scope` found in datum,
  starting from zero."
  [datum]
  (let [c (atom {})]
    (clojure.walk/postwalk
     (fn [x]
       (if (instance? Variable x)
         (let [[sym scopes] (destructure-variable x)
               syms (swap!
                     c
                     #(let [r (set/difference scopes
                                              (set (keys %)))]
                        (into %
                              (map-indexed
                               (fn [n a]
                                 [a (symbol (str "s" (+ (count %) n)))])
                               r))))]
           #_(->Variable sym (set (map #(get syms %) scopes)))
           [sym (set (map #(get syms %) scopes))])
         x))
     datum)))

(defn unscope
  "Remove all scopes from the variables found in datum."
  [datum]
  (clojure.walk/postwalk
   (fn [x]
     (if (instance? Variable x)
       (variable-symbol x)
       x))
   datum))

(defn us-expand [datum]
  (unscope (expand datum)))

(defn rg-expand [datum]
  (regensym (expand datum)))