mahjong-calc.clj

;;;; 2014-12-17
;;;; 麻雀あがり判定プログラム
;; (agari? "11122233344455m")
;; =>
;; ("123m123m123m444m55m"
;;  "111m234m234m234m55m"
;;  "111m234m345m345m22m"
;;  "111m222m333m444m55m")

;; 天和が出るまでひたすら配牌を繰り返す
;; (tenho-challenge)
;; =>
;; (:TENHO "3m7p7m7s1m8p6s北2m北9m8s9p8m"
;;  :FIGURE ("123m789m789p678s北北")
;;  :TRY 89941 :SEC 53 :TRY/SEC 1697)

;;;;;;; util
(defn Y [f]
  ((fn [x] (x x))
   (fn [x] (f #(x x)))))

(defn strict-take [n lst]
  (let [xs (take n lst)]
    (if (= n (count xs)) xs nil)))

(defn null? [x] (= x nil))

(defn iterate* [f x]
  (if (null? x) nil
    (cons x (lazy-seq (iterate* f (f x))))))

(defn empty-to-nil [lst] (if (empty? lst) nil lst))

;; (repeat-cat 3 '((白) (発)))
;; => ((白) (発) (白) (発) (白) (発))
(defn repeat-cat [n lst] (apply concat (repeat n lst)))

;; (remove (=x 1) '(1 2 3 1 2 3))
;; -> (2 3 2 3)
(defn =x [x & {:keys [then else]}]
  (fn [y] (if (= x y)
            (if then (then x y) x)
            (if else (else x y) nil))))

;; (with-key count + '(1 2 3) '(4 5 6))
;; -> 6
(defn with-key [key f & args] (apply f (map key args)))

;; (find-x 'c '(a b c d e))
;; -> c
(defn find-x [x lst]
  (if (empty? lst)
    nil
    (if (= x (first lst)) x
        (recur x (rest lst)))))

;; (remove-x 'a '(a b a b a b))
;; (b a b a b)
(defn remove-x
  ([x lst] (remove-x x lst 1))
  ([x lst n]
     (if (or (empty? lst) (= n 0))
       lst
       (if (= x (first lst))
         (lazy-seq (remove-x x (rest lst) (dec n)))
         (cons (first lst) (lazy-seq (remove-x x (rest lst) n)))))))

;; (remove-xs '(a a b) '(a b a a c d e))
;; => (a c d e)
(defn remove-xs [xs lst]
  (if (or (empty? xs) (empty? lst))
    lst
    (if-let [found (find-x (first lst) xs)]
      (lazy-seq (remove-xs (remove-x found xs) (rest lst)))
      (cons (first lst) (lazy-seq (remove-xs xs (rest lst)))))))

;; (intersection '(a b c) '(b c d))
;; -> (b c)
(defn intersection [a b]
  (if (empty? a)
    nil
    (if (find-x (first a) b)
      (cons (first a) (intersection (rest a) b))
      (intersection (rest a) b))))

(defn subset? [a b]
  "return a if a is subset of b"
  (if (every? #(find-x % b) a) a))

;; (remove-duplicate '((1 2 3) (4 5 6) 3 3 (1 2 3)))
;; => ((1 2 3) (4 5 6) 3)
;; (remove-duplicate (take 10 (iterate inc 0)) #(mod % 3))
;; => (0 1 2)
(defn remove-duplicate
  ([lst]
   (letfn [(rec [lst acc]
             (cond (empty? lst) (reverse acc)
                   (find-x (first lst) acc) (recur (rest lst) acc)
                   true (recur (rest lst) (cons (first lst) acc))))]
     (rec lst nil)))
  ([lst keyfn]
   (letfn [(rec [lst acc ac2]
             (if (empty? lst) (reverse acc)
                 (let [value (keyfn (first lst))]
                   (if (find-x value ac2)
                     (recur (rest lst) acc ac2)
                     (recur (rest lst) (cons (first lst) acc) (cons value ac2))))))]
     (rec lst nil nil))))

;; (or (f lst) (g lst) (h lst)) as
;; ((juxt-or f g h) lst)
(defn juxt-or [f & fns]
  (if (empty? fns)
    (fn [x] (f x))
    (fn [x] (or (f x) ((apply juxt-or fns) x)))))

;; (concat (f lst) (g lst) (h lst)) as
;; ((juxt-cat f g h) lst)
;; sample
;; (let [animals (set '(dog cat))
;;       fruilt (set '(apple oarnge))]
;;   ((juxt-cat #(filter animals %) #(filter fruilt %))
;;    '(dog cat apple MahJong Lisp)))
;; => (dog cat apple)
(defn juxt-cat [& fns]
  (fn [& args] (apply concat (map #(apply % args) fns))))

;;(remove-nth 2 '(0 1 2 3 4))
;; => (0 1 3 4)
(defn remove-nth [n lst]
  (if (> n 0)
    (cons (first lst) (remove-nth (dec n) (rest lst)))
    (rest lst)))

;; (random-take 4 '(0 1 2 3))
;; => (2 0 1 3)
(defn random-take [n lst]
  (loop [n n lst lst acc nil]
    (if (<= n 0) acc
        (let [rnd (int (rand (count lst)))]
          (recur (dec n) (remove-nth rnd lst) (cons (nth lst rnd) acc))))))

(defn iter-perm [v]
  (let [len (count v)
        left (loop [i (- len 2)]
               (cond (< i 0) nil
                     (< (v i) (v (inc i))) i
                     :else (recur (dec i))))]
    (when left
      (let [vl (v left)
            right (loop [i (dec len)]
                    (if (< vl (v i)) i (recur (dec i))))]
        (loop [v (assoc v left (v right) right (v left)) left (inc left) right (dec len)]
          (if (< left right)
            (recur (assoc v left (v right) right (v left)) (inc left) (dec right))
            v))))))

; (map #(apply str %) (take 10 (permutations "Permtation of Ruby")))
;; ("Permtation of Ruby"
;;  "Permtation of Ruyb"
;;  "Permtation of Rbuy"
;;  "Permtation of Rbyu"
;;  "Permtation of Ryub"
;;  "Permtation of Rybu"
;;  "Permtation of uRby"
;;  "Permtation of uRyb"
;;  "Permtation of ubRy"
;;  "Permtation of ubyR")
(defn permutations [lst]
  (let [v (vec lst)]
    (map #(map v %) (iterate* iter-perm (vec (range (count lst)))))))

(defn sfirst [lst] (second (first lst)))

;; (($ str) (concat (map second (reverse buf)) (list (ffirst buf))))
;=> "2345m"
(defn $ [f] (fn [arg] (apply f arg)))

;;;;;;; util end


(defn jihai? [pai] (= 1 (count pai)))

(def pai-order (into {} (map-indexed #(vector %2 %) '(m p s 東 南 西 北 白 発 中))))

;; (group-pais (random-hand))
;; =>(((m 1) (m 1) (m 3) (m 3) (m 4)) ((p 1) (p 2) (p 3)) ((s 1) (s 2) (s 5) (s 6) (s 9)) () () ((西)) () () () ())
(defn group-pais [hand]
  (let [set (group-by #(first %) hand)]
    (map #(sort-by second (set %)) '(m p s 東 南 西 北 白 発 中))))

;; (sort-hand (to-list "1m2s3p2m3m4p2s白2p発白"))
;; =>((m 1) (m 2) (m 3) (p 3) (p 4) (p 2) (s 2) (s 2) (白) (白) (発))
(defn sort-hand [hand] (apply concat (group-pais hand)))

(def all-pais
  (sort-hand
   (concat (repeat-cat 4 (mapcat (fn [x] (map #(list x %) (range 1 10))) '(m p s)))
           (repeat-cat 4 '((東) (南) (西) (北) (白) (発) (中))))))

(defn random-hand [] (random-take 14 all-pais))

;(sort-grouped-hand '(((m 2) (m 3) (m 4)) ((p 7) (p 8) (p 9)) ((p 4) (p 5) (p 6)) ((s 6) (s 7) (s 8)) ((西) (西))))
;=>(((m 2) (m 3) (m 4)) ((p 4) (p 5) (p 6)) ((p 7) (p 8) (p 9)) ((s 6) (s 7) (s 8)) ((西) (西)))
(defn sort-grouped-hand [grouped-hand]
  (sort-by (juxt #(* -1 (count %)) #(pai-order (ffirst %)) sfirst) grouped-hand))

;; (next-pai '(p 1))
;; -> (p 2)
(defn next-pai [p]
  (cond (< (count p) 2) nil
        (<= 9 (second p)) nil
        :else (list (first p) (inc (second p)))))

;; (num-to-list "123s")
;; -> ((s 1) (s 2) (s 3))
(defn num-to-list [s]
  (let [ary (vec s)
        c (symbol (str (last ary)))]
    (map #(list c (with-key int - % \0)) (butlast ary))))

;;;; (to-list "123s123456m789p白白")
;;-> ((s 1) (s 2) (s 3)
;;    (m 1) (m 2) (m 3) (m 4) (m 5) (m 6)
;;    (p 7) (p 8) (p 9)
;;    ("白") ("白"))
(defn to-list [s]
  (sort-hand
   (concat
    (mapcat num-to-list (re-seq #"\d+\w" s))
    (map #(list (symbol (str (last %)))) (re-seq #"\W" s)))))

;; (to-str (random-hand))
;=> "676s61m西9m9p2m東3s7p7m北"
(defn to-str [hand]
  (letfn [(rec [hand buf result]
            (if (empty? hand)
              (str result (($ str) (map second (reverse buf))) (ffirst buf))
              (if (= (ffirst hand) (ffirst buf))
                (recur (rest hand) (cons (first hand) buf) result)
                (recur (rest hand) (list (first hand))
                       (str result (apply str (map second (reverse buf))) (ffirst buf))))))]
    (rec hand nil nil)))

;; (pair-to-str '((m 1) (m 2) (m 3)))
;;=> "123m"
(defn pair-to-str [lst]
  (if (jihai? (first lst))
    (apply str (repeat (count lst) (ffirst lst)))
    (str (apply str (map second lst)) (ffirst lst))))

(defn grouped-hand-to-str [hand] (apply str (map pair-to-str hand)))

;; 関数を返す関数に関数を返す関数を適応して関数を返す関数
(defn get-pai-pairs-function-generator [pair-fn]
  (Y (fn [self]
       (fn
         ([lst] ((self) lst 0 nil))
         ([lst n acc]
            (if (<= (count lst) n)
              (reverse acc)
              (let [pair (pair-fn lst (nth lst n))]
                (if pair
                  ((self) lst (inc n) (cons pair acc))
                  ((self) lst (inc n) acc)))))))))

;; (get-toitu (to-list "123s333456m88p白白白"))
;; -> (((m 3) (m 3)) ((p 8) (p 8)) (("白") ("白")))
(def get-toitu
  (get-pai-pairs-function-generator
   (fn [lst pai] (strict-take 2 (filter (=x pai) lst)))))

;; (get-koutu (to-list "123s333456m88p白白白"))
;; -> (((m 3) (m 3) (m 3)) (("白") ("白") ("白")))
(def get-koutu
  (get-pai-pairs-function-generator
   (fn [lst pai] (strict-take 3 (filter (=x pai) lst)))))

;; (get-syuntu (to-list "123s333456m88p白白白"))
;; -> (((s 1) (s 2) (s 3)) ((m 3) (m 4) (m 5)))
(def get-syuntu
  (get-pai-pairs-function-generator
   (fn [lst pai] (subset? (strict-take 3 (iterate* next-pai pai)) lst))))

;; (get-syuntu-or-koutu (to-list "111222333s"))
;; =>
;; (((s 1) (s 2) (s 3))
;;  ((s 1) (s 1) (s 1))
;;  ((s 2) (s 2) (s 2))
;;  ((s 3) (s 3) (s 3)))
(def get-syuntu-or-koutu
  (comp remove-duplicate (juxt-cat get-syuntu get-koutu)))

(defn possibles [lst]
  (letfn [(rec [lst acc]
            (if (= 2 (count lst))
              (if (with-key #(nth lst %) = 0 1) (list (reverse (cons lst acc))) nil)
              (mapcat #(rec (remove-xs % lst) (cons % acc)) (get-syuntu-or-koutu lst))))]
    (empty-to-nil (remove-duplicate (map sort-grouped-hand (rec lst nil)) set))))

(defn agari? [hand] (map grouped-hand-to-str (possibles (to-list hand))))

(defn tenho-challenge []
  (letfn [(challenge [tenho try]
            (if tenho
              [tenho try]
              (let [hand (random-hand)]
                (when (zero? (mod try 1000)) (println try (to-str hand)))
                (if (possibles hand)
                  (recur hand (inc try) )
                  (recur nil (inc try))))))]
  (let [start (System/currentTimeMillis)]
    (let [[hand try] (challenge nil 0)]
      (let [end (System/currentTimeMillis)
            elapsed (int (/ (- end start) 1000))]
        `(:TENHO ~(to-str hand) :FIGURE ~(agari? (to-str hand))
         :TRY ~try :SEC ~elapsed  :TRY/SEC ~(int (/ try elapsed))))))))