fork download
copy 
  1. (defn mapv
  2.   "Returns a vector consisting of the result of applying f to the
  3. set of first items of each coll, followed by applying f to the set
  4. of second items in each coll, until any one of the colls is
  5. exhausted. Any remaining items in other colls are ignored. Function
  6. f should accept number-of-colls arguments."
  7.   {:added "1.4"
  8.    :static true}
  9.   ([f coll]
  10.      (-> (reduce (fn [v o] (conj! v (f o))) (transient []) coll)
  11.          persistent!))
  12.   ([f c1 c2]
  13.      (into [] (map f c1 c2)))
  14.   ([f c1 c2 c3]
  15.      (into [] (map f c1 c2 c3)))
  16.   ([f c1 c2 c3 & colls]
  17.      (into [] (apply map f c1 c2 c3 colls))))
  18.  
  19. (def v1 '[[A B C D]
  20.          [A C D B]
  21.          [B A D C]
  22.          [D C A B]])
  23.  
  24.  
  25. (def v2 '[[A B C D E F]
  26.          [B C D E F A]
  27.          [C D E F A B]
  28.          [D E F A B C]
  29.          [E F A B C D]
  30.          [F A B C D E]])
  31.  
  32. (def v3 '[[A B C D]
  33.          [B A D C]
  34.          [D C B A]
  35.          [C D A B]])
  36.  
  37. (def v4 '[[B D A C B]
  38.          [D A B C A]
  39.          [A B C A B]
  40.          [B C A B C]
  41.          [A D B C A]])
  42.  
  43. (def v5 [ [2 4 6 3]
  44.         [3 4 6 2]
  45.           [6 2 4] ])
  46.  
  47. (def v6 [[1]
  48.         [1 2 1 2]
  49.         [2 1 2 1]
  50.         [1 2 1 2]
  51.         [] ])
  52.  
  53. (def v7 [[3 1 2]
  54.         [1 2 3 1 3 4]
  55.         [2 3 1 3] ])
  56.  
  57. (def v8 [[8 6 7 3 2 5 1 4]
  58.         [6 8 3 7]
  59.         [7 3 8 6]
  60.         [3 7 6 8 1 4 5 2]
  61.               [1 8 5 2 4]
  62.               [8 1 2 4 5]])
  63.  
  64.  
  65. (defn max-row-len
  66.   "returns the length of the lengthiest row of a matrix"
  67.   [x]
  68.   (reduce max (map count x)))
  69.  
  70. (defn min-row-len
  71.   "returns the lengths of the shortest row of a matrix"
  72.   [x]
  73.   (reduce min (map count x)))
  74.  
  75. (defn fill-x
  76.   "fills all shorter rows of a matrix with :nil, if applicable"
  77.   [x]
  78.   (loop [y []
  79.          row 0]
  80.     (cond (= row (count x)) y
  81.           :else (recur
  82.                  (cond (< (count (nth x row)) (max-row-len x))
  83.                        (conj y
  84.                              (vec
  85.                               (concat (nth x row)
  86.                                       (take (- (max-row-len x)
  87.                                                (count (nth x row))) (repeat :nil)))))
  88.                        :else (conj y (nth x row)))
  89.                  (inc row)))))
  90.  
  91.  
  92.  
  93. (defn contains-:nil?
  94.   "returns true, if the seq contains :nil"
  95.   [x]
  96.   (cond (= (some #{:nil} (flatten x)) :nil) true :else false))
  97.  
  98. (defn only-:nil?
  99.   "returns true, if the seq contains only :nil"
  100.   [x]
  101.   (= (count (filter (fn [y] (= :nil y)) (flatten x))) (count (flatten x))))
  102.  
  103. (defn any-:nil?
  104.   "returns true, if the seq contains any :nil"
  105.   [x]
  106.   (= (count (filter (fn [y] (= :nil y)) (flatten x))) 0))
  107.  
  108.  
  109. (defn shift-row
  110.   "returns the right-shifted vector, if the last element is :nil;
  111. nil otherwise"
  112.   [row]
  113.   (assert (not (nil? row)))
  114.   (cond (or (only-:nil? row) (not= (last row) :nil)) nil
  115.         :else (vec (concat [:nil] (butlast row)))))
  116.  
  117. (defn append-variants
  118.   "returns a vector of matrices, which results from appending all variants
  119. (by right-shifting) of the right-aligned vector to the matrix;
  120. this applies analogously, if the input matrix is nil"
  121.   [x v]
  122.   (assert (or (only-:nil? v) (not= (first v) :nil))) ; right-aligned vector
  123.   (cond (or (any-:nil? v) (only-:nil? v)) (conj [] (vec (conj x v)))
  124.         :else (loop [y []
  125.                      w v]
  126.                 (cond (nil? w) y
  127.                       :else (recur (conj y (vec (conj x w))) (shift-row w))))))
  128.  
  129.  
  130. (defn build-search-base
  131.   "generates the vector of all matrix variants to be derived from the
  132. nontrivial, filled matrix"
  133.   [x]
  134.   (assert (not (nil? x)))
  135.   (assert (<= 2 (count x)))
  136.   (assert (<= 2 (min-row-len x)))
  137.   (assert (= (min-row-len x) (max-row-len x)))
  138.   (cond (any-:nil? x) (vector x)
  139.         :else (loop [y (append-variants nil (nth x 0))
  140.                      row-x 1]
  141.                 (cond (= row-x (count x)) y
  142.                       :else (recur
  143.                              (loop [iter-y 0
  144.                                     new-y []]
  145.                                (cond (= iter-y (count y)) new-y
  146.                                :else (recur
  147.                                       (inc iter-y)
  148.                                       (into new-y
  149.                                             (append-variants (nth y iter-y)
  150.                                                              (nth x row-x))))))
  151.                              (inc row-x))))))
  152.  
  153.  
  154.  
  155. (defn part-rows
  156.   "generates from a filled matrix the grid of all possible sub-squares
  157. of a given sub-dimension"
  158.   [x dim]
  159.   (assert (= (max-row-len x) (min-row-len x))) ; i.e. filled matrix
  160.   (assert (<= 2 dim (count x)))
  161.   (assert (<= 2 dim (max-row-len x)))
  162.   (mapv #( vec (partition dim 1 (take dim (repeat :nil)) %)) x))
  163.  
  164.  
  165. (defn build-grid-base
  166.   "generates for the given filled matrix the vector of the grid matrices
  167. for all possible dimensions"
  168.   [x]
  169.   (assert (not (nil? x)))
  170.   (assert (<= 2 (count x)))
  171.   (assert (<= 2 (min-row-len x)))
  172.   (assert (= (min-row-len x) (max-row-len x)))
  173.   (loop [y [(part-rows x 2)]
  174.          dim 3]
  175.     (cond (> dim (min (count x) (min-row-len x))) y
  176.           :else (recur (into y [(part-rows x dim)]) (inc dim)))))
  177.  
  178.  
  179. (defn square-at
  180.   "returns the square of the given dimension at position i, j from a grid
  181. of all possible sub-squares of the same dimension"
  182.   [parted-x dim i j]
  183.   (assert (= dim (count (nth (nth parted-x 0) 0))))
  184.   ;(assert (<= 2 dim (count (nth parted-x 0))))
  185.   (assert (<= 2 dim (count parted-x)))
  186.   (loop [y []
  187.          di 0]
  188.     (cond (= di dim) y
  189.           :else (recur (conj y (nth (nth parted-x (+ i di)) j)) (inc di)))))
  190.  
  191.  
  192.  
  193.  
  194. ;user> (mapv concat (map vector [1 2 3]) (map vector [4 5 6]))
  195. ;[(1 4) (2 5) (3 6)]
  196. ;user> (partition 3 (interleave [1 2 3 4 5] [6 7 8 9 10] [5 4 3 2 1]))
  197. ;((1 6 5) (2 7 4) (3 8 3) (4 9 2) (5 10 1))
  198. ;user> (transpose [[1 2 3 4 5] [6 7 8 9 10] [5 4 3 2 1]])
  199. ;[(1 6 5) (2 7 4) (3 8 3) (4 9 2) (5 10 1)]
  200. (defn transpose
  201.   "returns the transpose of the matrix.
  202. BUG: returns vector of lists instead vector of vectors."
  203.   [m]
  204.   (loop [y (map vector (nth m 0))
  205.          i 1]
  206.     (cond (= i (count m)) y
  207.           :else (recur (mapv concat y (map vector (nth m i))) (inc i)))))
  208.  
  209. (defn max-row-member
  210.   "returns the maximum number of distinct elements per rows of a matrix"
  211.   [x]
  212.   (reduce max (map #(count (set %)) x)))
  213.  
  214. (defn min-row-member
  215.   "returns the minimum number of distinct elements per rows of a matrix"
  216.   [x]
  217.   (reduce min (map #(count (set %)) x)))
  218.  
  219.  
  220. (defn latin-square?
  221.   "returns true, if the given matrix is a latin square"
  222.   [s]
  223.   (let [dim (max-row-len s)]
  224.     (cond (and (not (contains-:nil? s))
  225.                (= dim
  226.                   (count s)
  227.                   (min-row-len s)
  228.                   (count (set (flatten s)))
  229.                   (count (set s))
  230.                   (count (set (transpose s)))
  231.                   (min-row-member s)
  232.                   (max-row-member s)
  233.                   (min-row-member (transpose s))
  234.                   (max-row-member (transpose s))))
  235.           true
  236.           :else false)))
  237.  
  238.  
  239. (defn count-a-grid-item
  240.   "returns the set of latin squares for the given grid item, i.e. the set of
  241. latin squares of the dimension that is associated to the given grid item"
  242.   [x]
  243.   (assert (not (nil? x)))
  244.   (let [dim-sq (count (nth (nth x 0) 0))
  245.         dim-x-x (inc (- (count x) dim-sq))
  246.         dim-x-y (count (nth x 0))]
  247.     (loop [sq (square-at x dim-sq 0 0)
  248.            result (cond (latin-square? sq) (conj #{} sq)
  249.                         :else #{})
  250.            i 0
  251.            j 1]
  252.       (cond (= i dim-x-x) result
  253.             :else (recur (cond (and (< i dim-x-x) (< j dim-x-y))
  254.                                (square-at x dim-sq i j)
  255.                                :else sq)
  256.                          (cond (and (< i dim-x-x) (< j dim-x-y))
  257.                                (cond (latin-square? sq) (conj result sq)
  258.                                      :else result)
  259.                                :else result)
  260.                          (cond (= j dim-x-y) (inc i)
  261.                                :else i)
  262.                          (cond (= j dim-x-y) 0
  263.                                :else (inc j)))))))
  264.  
  265.  
  266.  
  267. (defn solve
  268.   [x]
  269.   "return the accumulated set of latin squares in the given matrix"
  270.   (let [search-base (build-search-base (fill-x x))
  271.         dim-base (count search-base)
  272.         result (atom [])]
  273.     (doseq [i (range dim-base)]
  274.       (let [grid-base (build-grid-base (nth search-base i))]
  275.         (doseq [j (range (count grid-base))]
  276.           (swap! result into (count-a-grid-item (nth grid-base j))))))
  277.     (set @result)))
  278.  
  279.  
  280. (defn summary
  281.   [lsq]
  282.   "calculate the result summary from the given accumulated set of latin squares
  283. (http://l...content-available-to-author-only...f.org/clojure/maps/algorithms/histogram)"
  284.   (reduce conj {} (for [[x xs]
  285.                         (group-by identity
  286.                                   (sort < (for [r lsq]
  287.                                     (count r))))]
  288.                     [x (count xs)])))
  289.  
  290. (println (summary (solve v8)))
Success #stdin #stdout 3.79s 220224KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
{4 1, 3 1, 2 7}
https://ideone.com/3HtuO3
language:
Clojure (clojure 1.10.0)
created:
13 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!