(defmacro structure [n & body]
  (let [form `(do
                (in-ns '~n)
                (clojure.core/require '[~'clojure.core :as ~'cc])
                ~@body)]
    `(let [ns# (ns-name *ns*)]
       (try
         (eval '~form)
         (finally
           (in-ns ns#))))))

(defmacro functor [args & body]
  {:args (list 'quote args)
   :body (list 'quote body)})

(defmacro apply-functor [f params result]
  (let [{:keys [args body]} @(resolve f)]
    (doto `(structure
           ~result
           ~@(map
              (fn [arg param]
                `(alias '~arg '~param))
              args
              params)
           ~@body)
      prn)))

(structure
 node-ops

 (cc/defn leaf [keys]
   {:type :leaf
    :keys keys
    :size (cc/count keys)})

 (cc/defn branch [keys pivots]
   {:type :branch
    :keys keys
    :pivots pivots
    :size (cc/apply cc/+ (cc/count keys) (cc/map :size pivots))})

 (cc/defn match-node [tree leaf-fn branch-fn]
   (cc/case (:type tree)
     :leaf (leaf-fn (:keys tree) (:size tree))
     :branch (branch-fn (:keys tree) (:size tree) (:pivots tree))
     (throw (cc/ex-info "not a node" {:value tree}))))

 (cc/defn key-count [node]
   (cc/count (:keys node)))

 )


(structure
 btree3-config
 (def max-keys 3)
 (cc/defn compare [a b] (cc/compare a b)))




(def btree
  (functor
   [node-ops config]
   
   (cc/defn binary-search [needle haystack low high]
     (if (cc/< low high)
       (cc/let [middle (cc/quot (cc/+ low (cc/dec high)) 2)
                c (config/compare
                   (haystack middle)
                   needle)]
         (cc/cond (cc/< c 0)
                  (recur needle haystack (cc/inc middle) high)
                  (cc/> c 0)
                  (recur needle haystack low (cc/dec high))
                  :else
                  middle))
       low))
   
   (def empty (node-ops/leaf []))
   
   (cc/defn values [tree]
     (node-ops/match-node
      tree
      (cc/fn [keys size]
        keys)
      (cc/fn [keys size pivots]
        ((cc/fn f [keys [pivot & pivots]]
           (cc/concat (values pivot)
                      (cc/when (cc/seq pivots)
                        (cc/cons (cc/first keys)
                                 (f (cc/rest keys) pivots)))))
         keys
         pivots))))
   
   (cc/defn delete [tree key]
     (cc/letfn [(smash-keys [i neighbor-keys keys new-keys-of-pivot]
                  (if (cc/zero? i)
                    (cc/into (cc/into [(cc/nth keys i)] neighbor-keys) new-keys-of-pivot)
                    (cc/into (cc/conj neighbor-keys (cc/nth keys (cc/dec i)))
                             new-keys-of-pivot)))
                (drop-and-replace-pivot [i pivots smashed-keys]
                  (if (cc/zero? i)
                    (cc/assoc (cc/into (cc/subvec pivots 0 i)
                                       (cc/subvec pivots (cc/inc i)))
                              i
                              (node-ops/leaf smashed-keys))
                    (cc/assoc (cc/into (cc/subvec pivots 0 i)
                                       (cc/subvec pivots (cc/inc i)))
                              (cc/dec i)
                              (node-ops/leaf smashed-keys))))
                (drop-key [i keys]
                  (if (cc/zero? i)
                    (cc/into (cc/subvec keys 0 i)
                             (cc/subvec keys (cc/inc i)))
                    (cc/into (cc/subvec keys 0 (cc/dec i))
                             (cc/subvec keys i))))
                (del-at-pivot [key kont-update kont-underflow kont-no-change i keys pivots]
                  (del (cc/nth pivots i)
                       key
                       (cc/fn [new-pivot]
                         (kont-update (node-ops/branch keys (cc/assoc pivots i new-pivot))))
                       (cc/fn [new-keys-of-pivot]
                         (node-ops/match-node
                          (if (cc/zero? i)
                            (cc/nth pivots (cc/inc i))
                            (cc/nth pivots (cc/dec i)))
                          (cc/fn [neighbor-keys size]
                            (cc/let [smashed-keys (smash-keys i neighbor-keys keys new-keys-of-pivot)]
                              (if (cc/> config/max-keys (cc/count smashed-keys))
                                (cc/let [new-pivots (drop-and-replace-pivot i pivots smashed-keys)
                                         new-keys (drop-key i keys)]
                                  (if (cc/seq new-keys)
                                    (kont-update
                                     (node-ops/branch
                                      new-keys
                                      new-pivots))
                                    (kont-underflow
                                     (cc/reduce
                                      (cc/fn f [accum pivot]
                                        (node-ops/match-node
                                         pivot
                                         (cc/fn [keys size]
                                           (cc/into accum keys))
                                         (cc/fn [keys size pivots]
                                           (cc/assert nil "Q"))))
                                      []
                                      new-pivots))))
                                (do
                                  (cc/assert (cc/> i 0))
                                  (cc/let [left-keys (cc/subvec smashed-keys 0 (cc/quot (cc/count smashed-keys) 2))
                                           middle (cc/nth smashed-keys (cc/quot (cc/count smashed-keys) 2))
                                           right-keys (cc/subvec smashed-keys (cc/inc (cc/quot (cc/count smashed-keys) 2)))]
                                    (kont-update
                                     (node-ops/branch
                                      (cc/assoc keys (cc/dec i) middle)
                                      (cc/assoc pivots (cc/dec i)
                                                (node-ops/leaf left-keys)
                                                i
                                                (node-ops/leaf right-keys)))))))))
                          (cc/fn [neighbor-keys size neighbor-pivots]
                            (cc/assert nil "F"))))
                       kont-no-change))
                (del [tree key kont-update kont-underflow kont-no-change]
                  (node-ops/match-node
                   tree
                   (cc/fn [keys size]
                     ;; TODO bs
                     (cc/let [new-keys (cc/vec (cc/remove #{key} keys))]
                       (if (cc/> (cc/quot config/max-keys 2) (cc/count new-keys))
                         (kont-underflow new-keys)
                         (kont-update (node-ops/leaf new-keys)))))
                   (cc/fn [keys size pivots]
                     (cc/let [i (binary-search key keys 0 (cc/count keys))]
                       (if (cc/= i (cc/count keys))
                         (del-at-pivot key
                                       kont-update
                                       (cc/fn [new-pivots]
                                         (cc/assert nil "A"))
                                       kont-no-change
                                       i
                                       keys
                                       pivots)
                         (cc/let [c (config/compare key (cc/nth keys i))]
                           (cc/cond (cc/neg? c)
                                    (del-at-pivot key
                                                  kont-update
                                                  (cc/fn [new-pivots]
                                                    (cc/assert nil "C"))
                                                  kont-no-change
                                                  i keys pivots)
                                    (cc/zero? c)
                                    (node-ops/match-node
                                     (cc/nth pivots i)
                                     (cc/fn [keys' size']
                                       (del-at-pivot (cc/last keys')
                                                     kont-update
                                                     kont-underflow
                                                     kont-no-change
                                                     i
                                                     (cc/assoc keys i (cc/last keys'))
                                                     pivots))
                                     (cc/fn [keys' size' pivtos']
                                       (cc/assert nil "H")))
                                    :else
                                    (cc/assert nil "B"))))))))]
       (del tree
            key
            cc/identity
            (cc/fn [new-pivot-keys]
              (cc/assert (cc/not (cc/some cc/map? new-pivot-keys)))
              (node-ops/leaf new-pivot-keys))
            cc/identity)))
   
   (cc/defn insert [tree key]
     (cc/letfn [(insert-at-pivot [tree key kont-update kont-split kont-no-change i keys pivots]
                  (ins (cc/nth pivots i)
                       key
                       (cc/fn [new-pivot]
                         (cc/let [new-keys keys
                                  new-pivots (cc/assoc pivots i new-pivot)]
                           (kont-update (node-ops/branch new-keys new-pivots))))
                       (cc/fn [left-tree middle right-tree]
                         (cc/assert (cc/map? left-tree))
                         (cc/assert (cc/map? right-tree))
                         (cc/let [left-keys (cc/subvec keys 0 i)
                                  right-keys (cc/subvec keys i)
                                  new-keys (cc/into (cc/conj left-keys middle) right-keys)
                                  left-pivots (cc/subvec pivots 0 i)
                                  right-pivots (cc/subvec pivots (cc/inc i))
                                  new-pivots (cc/into (cc/conj left-pivots left-tree right-tree)
                                                      right-pivots)]
                           (if (cc/> (cc/count new-keys) config/max-keys)
                             (cc/let [left-keys (cc/subvec new-keys 0 (cc/quot (cc/count new-keys) 2))
                                      middle-key (cc/nth new-keys (cc/quot (cc/count new-keys) 2))
                                      right-keys (cc/subvec new-keys (cc/inc (cc/quot (cc/count new-keys) 2)))
                                      left-pivots (cc/subvec new-pivots 0 (cc/inc (cc/quot (cc/count new-pivots) 2)))
                                      right-pivots (cc/subvec new-pivots (cc/inc (cc/quot (cc/count new-pivots) 2)))]
                               (cc/assert (cc/= (cc/count left-keys) (cc/dec (cc/count left-pivots))))
                               (cc/assert (cc/= (cc/count right-keys) (cc/dec (cc/count right-pivots))))
                               (kont-split (node-ops/branch left-keys left-pivots)
                                           middle-key
                                           (node-ops/branch right-keys right-pivots)))
                             (kont-update (node-ops/branch new-keys new-pivots)))))
                       kont-no-change))
                (ins [tree key kont-update kont-split kont-no-change]
                  (node-ops/match-node
                   tree
                   (cc/fn [keys size]
                     (cc/let [i (binary-search key keys 0 (cc/count keys))]
                       (cc/let [new-keys (cc/cond (cc/= i (cc/count keys))
                                                  (cc/conj keys key)
                                                  (cc/zero? (config/compare key (cc/nth keys i)))
                                                  (cc/assoc keys i key)
                                                  :else
                                                  (cc/into (cc/conj (cc/subvec keys 0 i) key) (cc/subvec keys i)))]
                         (if (cc/> (cc/count new-keys) config/max-keys)
                           (cc/let [left-tree (node-ops/leaf (cc/subvec new-keys 0 (cc/quot (cc/count new-keys) 2)))
                                    right-tree (node-ops/leaf (cc/subvec new-keys (cc/inc (cc/quot (cc/count new-keys) 2))))
                                    middle (cc/nth new-keys (cc/quot (cc/count new-keys) 2))]
                             (kont-split left-tree middle right-tree))
                           (kont-update (node-ops/leaf new-keys))))))
                   (cc/fn [keys size pivots]
                     (cc/let [i (binary-search key keys 0 (cc/count keys))]
                       (if (cc/> (cc/count keys) i)
                         (cc/let [c (config/compare key (cc/nth keys i))]
                           (cc/cond (cc/neg? c)
                                    (insert-at-pivot tree key kont-update kont-split kont-no-change i keys pivots)
                                    (cc/zero? c)
                                    (kont-update
                                     (node-ops/branch
                                      (cc/assoc keys i key)
                                      pivots))
                                    :else
                                    (cc/assert nil)))
                         (insert-at-pivot tree key kont-update kont-split kont-no-change i keys pivots))))))]
       (ins tree key cc/identity
            (cc/fn [left-tree middle right-tree]
              (node-ops/branch [middle] [left-tree right-tree]))
            (cc/constantly tree))))))

(apply-functor btree [node-ops btree3-config] btree3)

(assert (= {:type :leaf, :keys [1], :size 1} (btree3/insert btree3/empty 1)))

(assert (= {:type :branch,
            :keys [4],
            :size 4
            :pivots [{:type :leaf, :keys [0 1] :size 2}
                     {:type :leaf, :keys [6] :size 1}]}
           (-> btree3/empty
               (btree3/insert 1)
               (btree3/insert 0)
               (btree3/insert 4)
               (btree3/insert 6))))

(assert (= {:type :branch,
            :keys [4],
            :size 5
            :pivots [{:type :leaf, :keys [0 1] :size 2}
                     {:type :leaf, :keys [5 6] :size 2}]}
           (-> btree3/empty
               (btree3/insert 1)
               (btree3/insert 0)
               (btree3/insert 4)
               (btree3/insert 6)
               (btree3/insert 5))))

(assert (= {:type :branch,
            :keys [4 8],
            :size 7
            :pivots [{:type :leaf,
                      :keys [0 1]
                      :size 2}
                     {:type :leaf,
                      :keys [5 6]
                      :size 2}
                     {:type :leaf,
                      :keys [10]
                      :size 1}]}
           (-> btree3/empty
               (btree3/insert 1)
               (btree3/insert 0)
               (btree3/insert 4)
               (btree3/insert 6)
               (btree3/insert 5)
               (btree3/insert 10)
               (btree3/insert 8))))



(-> btree3/empty
    (btree3/insert 1)
    (btree3/insert 0)
    (btree3/insert 4)
    (btree3/insert 6)
    (btree3/insert 5)
    (btree3/insert 10)
    (btree3/insert 8)
    (btree3/delete 10)
    (btree3/delete 0)
    (btree3/delete 6)
    (btree3/delete 8)
    (btree3/delete 4)
    (btree3/delete 1)
    (btree3/delete 5)
    (assert (= btree3/empty)))