adhoc parquet layout, random search, no optimization. Hot reload to update.

core.cljc

(ns parquet-layout.core)

(defn destock
  ([stock] stock)
  ([stock board]
   (let [n (dec (stock board))]
     (if (zero? n)
       (dissoc stock board)
       (assoc stock board n)))))

(defn restock [stock board]
  (cond-> stock
    board (assoc board (inc (stock board 0)))))

(defn update-stock [stock boards min-ends-width]
  (-> (transduce (map first) destock stock boards)
    (restock (let [[[type w & more] w'] (first boards)]
               (case type
                 :full
                 (let [w (- w w')]
                   (when (<= min-ends-width w)
                     (into [:end w] more)))
                 nil)))
    (restock (let [[[type w & more] w'] (last boards)]
               (case type
                 :full
                 (let [w (- w w')]
                   (when (<= min-ends-width w)
                     (into [:start w] more)))
                 nil)))))

(defn joints [boards]
  (next (reductions + 0 (->> boards (drop-last 1) (map second)))))

(defn layout [stock prev-row-widths n total-width
              {:keys [step min-joints-distance min-ends-width]
               :or {step 5 min-joints-distance 20 min-ends-width 30}}]
  (letfn [(layout1 [stock rem-joints x]
            (let [rem-width (- total-width x)
                  [joint & more-joints] (seq rem-joints)]
              (when-not (and joint (< (- joint min-joints-distance) x (+ joint min-joints-distance)))
                (if (some-> joint (< x))
                  (recur stock more-joints x)
                  (for [[[type w :as board] n]
                        (concat
                          (when (zero? x) (shuffle (filter (fn [[[type]]] (= type :start)) stock)))
                          (shuffle (filter (fn [[[type]]] (= type :end)) stock))
                          (shuffle (filter (fn [[[type w]]] (and (= type :full) (<= w rem-width))) stock))
                          (sort-by (fn [[[type w]]] w) (filter (fn [[[type w]]] (and (= type :full) (> w rem-width))) stock)))
                        :when (pos? n)
                        :when (case type :start (zero? x) true)
                        w (if (zero? x)
                            (reverse (range min-ends-width (inc w) step)) ; maximize use
                            (list w))
                        :let [x' (+ x w)
                              overflow (- x' total-width)
                              full (<= 0 overflow)
                              w (cond-> w full (- overflow))]
                        :when (case type :end full true)
                        :when (or (not full) (<= min-ends-width w))
                        next-boards (if full
                                      (list nil)
                                      (layout1 (destock stock board) rem-joints x'))]
                    (cons (list board w) next-boards))))))
          (layout* [stock prev-row n]
            (if (pos? n)
              (for [row (layout1 stock (joints prev-row) 0)
                    rows (layout* (update-stock stock row min-ends-width) row (dec n))]
                (cons row rows))
              (list nil)))]
    (layout* stock (map (fn [w] [:fake w]) prev-row-widths) n)))

(defn sample-stock [stock n w]
  (loop [sample-stock {} rem (* n w 1.02)
         boards
         (->> stock
             (mapcat (fn [[board n]] (repeat n board)))
             shuffle)]
    (if (pos? rem)
      (when-some [[board & boards] (seq boards)]
        (recur (restock sample-stock board) (- rem (second board)) boards))
      sample-stock)))

(defn sample-stocks [stocks n w]
  (let [ab (/ 44 65.0)
        ru (- 1 ab)]
    (-> {}
      (into
        (map (fn [[board n]] [(conj board :ab) n])
          (sample-stock (:ab stocks) n (* w ab))))
      (into
        (map (fn [[board n]] [(conj board :ru) n])
          (sample-stock (:ru stocks) n (* w ru)))))))

(defn inc-layout [stocks prev-row-widths n w]
  (let [batch (sample-stocks stocks n w)
        rows (first (layout batch prev-row-widths n w {}))
        #_#_stock (reduce #(update-stock %1 %2 30) stock rows)]
    {:rows rows
     #_#_:stock stock}))

(def ru
  (into {}
    (map (fn [[w n]] [[:full w] (* 5 n)]))
    {35	4
     40	12
     45	10
     50	6
     55	10
     60	4
     65	4
     70	10
     75	6
     80	10
     85	6
     90	6
     95	11
     100	9
     105	6
     110	4
     115	2
     120	6
     125	4}))

(def ab
  (into {}
    (map (fn [[w n]] [[:full w] (* 5 n)]))
    {30			5
     35			8
     40			10
     45			13
     50			6
     55			4
     60			4
     65			6
     70			6
     75			8
     80			8
     85			12
     90			8
     95			9
     100			4
     105			0
     110			2
     115			5
     120			2
     125			5}))

#_(inc-layout ru 30 300)

(def stock-initial {:ab ab :ru ru})

(def batches
  [; 1
   (map (fn [w] [(case w 30 :ab :ru) [:full w]])
     [100 40 35 55 85 125 90 55 40 40
      50 70 80 70 110 40 75 65 45 60
      95 65 90 100 100 90 85 40
      115 70 120 95 85 100 75
      65 70 125 70 40 55 120 65 50
      40 45 120 35 55 55 50 55 125 50 30])
   ; 2
   (for [row [[100 85 85 40 [70] 65 65 70 35 45]
              [[80] [80] 90 [40] [55] [55] 70 75 [105]]
              [45 80 80 [110] 55 75 [75] [45] 50 35]
              [[105] [40] 30 90 80 50 90 110 [55]]
              [35 [45] 45 95 [90] 110 [95] 45 90]
              [[55] 95 95 95 50 95 50 50 30 35]]
         #_#_:let [_ (prn (transduce (map #(cond-> % (vector? %) first)) + row))]
         w row]
     (if (vector? w) [:ru [:full (first w)]] [:ab [:full w]]))
   ; 3
   (for [row [[85 [125] [60] 45 95 [40] 60 [50] 90]
              [65 [115] 65 [110] 75 45 115 60]
              [45 85 85 [105] 85 95 [45] [70] 35]
              [65 100 125 90 [55] [45] 90 80]
              [115 [125] 30 50 40 [40] 100 [95] [55]]
              [35 30 75 40 115 [45] 40 [70] [125] 40 35]]
         #_#_:let [_ (prn (transduce (map #(cond-> % (vector? %) first)) + row))]
         w row]
     (if (vector? w) [:ru [:full (first w)]] [:ab [:full w]]))
   ; 4
   (for [row [[100 100 30 [45] 85 [40] 85 60 [105]]
              [[70] 90 [95] 60 120 [90] [85] 40]
              [[100] 110 75 [75] 110 [80] 35 65]
              [75 45 115 [95] [55] 35 80 30 80 40]
              [[45] [60] 95 [80] 90 90 125 [70]]
              [[60] 65 45 45 [35] 95 45 35 [55] 35 35 100]]
         :let [_ (prn (transduce (map #(cond-> % (vector? %) first)) + row))]
         w row]
     (if (vector? w) [:ru [:full (first w)]] [:ab [:full w]]))
   ])

(def stock (reduce
             (fn [stock batch]
               (reduce (fn [stock [cat board]]
                         (update stock cat destock board)) stock batch))
             stock-initial batches))

gui.cljd

(ns parquet-layout.gui
  (:require [parquet-layout.core :as p]
            ["package:flutter/material.dart" :as m]
            ["dart:ui" :as ui]
            [cljd.flutter :as f]))

(defn main []
  (f/run
    (m/MaterialApp
      .title "Welcome to Flutter"
      .theme (m/ThemeData .primarySwatch m.Colors/pink))
    .home
    (m/Scaffold
      .appBar (m/AppBar
                .title (m/Text "Parquet layout")))
    .body
    :let [_ (prn 'computing)
          prev-row-widths [60 65 45 45 35 95 45 35 55 35 35 100]
          rows (:rows (p/inc-layout p/stock prev-row-widths 6 648))
          _ (prn 'done rows)]
    m/Center
    (m/CustomPaint
      .painter
      (reify :extends m/CustomPainter
        (paint [_ canvas size]
          (let [paint (doto (m/Paint)
                        (.-color! m/Colors.black)
                        (.-style! m/PaintingStyle.stroke))]
            (doseq [[i row] (map-indexed vector rows)
                    :let [y (* i 20)]]
              (reduce (fn [x [[type w' cat] w]]
                        (when-not cat (prn [type w' cat]))
                        (let [rect (m/Rect.fromLTWH (* 2 x) y (* 2 w) 20)
                              tp (doto (m/TextPainter
                                         .textDirection m/TextDirection.ltr
                                         .textAlign m/TextAlign.center
                                         .text
                                         (m/TextSpan .text (str (if (= w w') (str w) (str w "/" w')) " " (name cat))
                                           .style (m/TextStyle .fontSize 16 .color m/Colors.black)))
                                   .layout)]
                          (.drawRect canvas rect paint)
                          (doto tp
                            (.paint canvas (.center (.* (.-size tp) -1.0) (.-center rect)))
                            .dispose))
                        (+ x w))
                0 row))))
        (shouldRepaint [_ _] false)))
    (m/SizedBox.expand)))