Initial commit: make TUI tool (1d31fab) - jigsaw_gen

tool.hy

...	...	@@ -0,0 +1,194 @@
	1	+(require hyrule [-> case unless])
	2	+(import hyrule [dec inc])
	3	+(import curses math random sys)
	4	+
	5	+(setv WIDTH None)
	6	+(setv SHAPE-CHARS (list "#$%&*+/=?"))
	7	+(setv COL-DEPTH 15)
	8	+
	9	+(defn gx [x] (if (isinstance x tuple) (get x 0) (lfor k x (gx k))))
	10	+
	11	+(defn gy [x] (if (isinstance x tuple) (get x 1) (lfor k x (gy k))))
	12	+
	13	+(defn in-bounds [x y w h] (and (>= x 0) (>= y 0) (< x w) (< y h)))
	14	+
	15	+(defn rotate [shape qta]
	16	+ (sfor #(x y) shape #(
	17	+ (+ (* (** -1 (// qta 2)) (% (inc qta) 2) x) (* -1 (** -1 (// qta 2)) (% qta 2) y))
	18	+ (+ (* (** -1 (// qta 2)) (% (inc qta) 2) y) (* (** -1 (// qta 2)) (% qta 2) x)))))
	19	+
	20	+(defn translate [shape dx dy]
	21	+ (sfor #(x y) shape #((+ x dx) (+ y dy))))
	22	+
	23	+(defn normalise [shape]
	24	+ (translate shape (- (min (gx shape) :default 0)) (- (min (gy shape) :default 0))))
	25	+
	26	+(defn init-grid [w h]
	27	+ (dfor x1 (range w) y1 (range h)
	28	+ #(x1 y1) (sfor #(x2 y2) [#((dec x1) y1) #(x1 (dec y1)) #((inc x1) y1) #(x1 (inc y1))]
	29	+ :if (in-bounds x2 y2 w h) #(x2 y2))))
	30	+
	31	+(defn draw [scr shape ch [bg " "] [w 0] [h 0]]
	32	+ (if (isinstance scr curses.window)
	33	+ (if shape (for [#(x y) shape] (scr.addch y x ch)) "")
	34	+ (if shape (let [cg (or scr (lfor _ (range (or h (inc (max (gy shape)))))
	35	+ (lfor _ (range (or w (inc (max (gx shape))))) bg)))]
	36	+ (for [#(x y) shape] (setv (get cg y x) ch))
	37	+ cg) scr)))
	38	+
	39	+(defn to-pbm [shapes]
	40	+ (setv w (+ 2 (max (lfor s shapes (- (max (gx s)) (min (gx s)) -1)))))
	41	+ (setv h (inc (sum (lfor s shapes (inc (- (max (gy s)) (min (gy s)) -1))))))
	42	+ (setv header f"P1\n{w} {h}\n")
	43	+ (+ header (.join "\n" (lfor s shapes
	44	+ (.join "\n" (lfor r (draw "" (translate (normalise s) 1 1) "1" "0" w) (.join "" r)))))
	45	+ "\n" (* "0" w) "\n"))
	46	+
	47	+(defn colour [t]
	48	+ (defn ud [x] (let [y (-> x (% 0.5) (* 6) (min 1))]
	49	+ (round (* COL-DEPTH (if (>= (% x 1) 0.5) (- 1 y) y)))))
	50	+ (let [r (ud (+ t (/ 1 3))) g (ud t) b (ud (+ t (/ 2 3)))] f"{r} {g} {b}"))
	51	+
	52	+(defn to-ppm [shapes]
	53	+ (setv w (+ 3 (max (lfor s shapes (max (gx s))))))
	54	+ (setv h (+ 3 (max (lfor s shapes (max (gy s))))))
	55	+ (setv header f"P3\n{w} {h}\n{COL-DEPTH}\n")
	56	+ (setv grid (draw "" #{#(0 0)} "0 0 0" "0 0 0" w h))
	57	+ (for [#(i s) (enumerate shapes)]
	58	+ (setv grid (draw grid (translate s 1 1) (colour (/ i (len shapes))))))
	59	+ (+ header (.join "\n" (lfor r grid (.join " " r))) "\n"))
	60	+
	61	+(defn nbhd [xy]
	62	+ (lfor d [#(1 0) #(0 1) #(-1 0) #(0 -1)] #((+ (gx xy) (gx d)) (+ (gy xy) (gy d)))))
	63	+
	64	+(defn hop-shape [xy src dst]
	65	+ (setv (get dst xy) #{})
	66	+ (del (get src xy))
	67	+ (for [sc (nbhd xy)]
	68	+ (when (in sc dst) (.add (get dst xy) sc) (.add (get dst sc) xy))
	69	+ (when (in sc src) (.discard (get src sc) xy))))
	70	+
	71	+(defn components [shape]
	72	+ (setv pl (set (shape.keys)))
	73	+ (setv comps [])
	74	+ (setv comp [])
	75	+ (setv fi 0)
	76	+ (while pl
	77	+ (if (>= fi (len comp))
	78	+ (do (when comp (comps.append (set comp))) (setv comp [(pl.pop)]) (setv fi 0))
	79	+ (do
	80	+ (for [ap (nbhd (get comp fi))]
	81	+ (when (in ap pl) (comp.append ap) (pl.remove ap)))
	82	+ (+= fi 1))))
	83	+ comps)
	84	+
	85	+(defn equiv [s1 s2]
	86	+ (let [ns2 (normalise s2)]
	87	+ (any (lfor r (range 4) (not (.symmetric-difference (normalise (rotate s1 r)) ns2))))))
	88	+
	89	+(defn builder [stdscr]
	90	+ (setv KND {
	91	+ (ord "h") #(-1 0) (ord "t") #(0 1)
	92	+ (ord "n") #(0 -1) (ord "s") #(1 0)
	93	+ curses.KEY-LEFT #(-1 0) curses.KEY-DOWN #(0 1)
	94	+ curses.KEY-UP #(0 -1) curses.KEY-RIGHT #(1 0)})
	95	+ (stdscr.clear)
	96	+ (setv epi 0)
	97	+ (setv cursor #(0 0))
	98	+ (setv k 0)
	99	+ (setv message "")
	100	+ (while (!= k (ord "q"))
	101	+ (stdscr.refresh)
	102	+ (when (in k KND)
	103	+ (let [d (get KND k) w #((+ (gx cursor) (gx d)) (+ (gy cursor) (gy d)))]
	104	+ (when (in-bounds (gx w) (gy w) WIDTH WIDTH) (setv cursor w))))
	105	+ (case (chr k)
	106	+ "r" (do
	107	+ (when (in cursor (get shapes 0))
	108	+ (unless epi (setv epi (len shapes)) (shapes.append {})))
	109	+ (setv rpc 0)
	110	+ (while (and
	111	+ (< (len (get shapes epi)) WIDTH)
	112	+ (setx opts (list (sfor rxy (\| (.keys (get shapes epi)) #{cursor}) nxy (nbhd rxy)
	113	+ :if (in nxy (get shapes 0)) nxy))))
	114	+ (setv cursor (random.choice opts))
	115	+ (hop-shape cursor (get shapes 0) (get shapes epi))
	116	+ (+= rpc 1))
	117	+ (setv message f"randomly picked {rpc}/{WIDTH} tiles ({(len (get shapes epi))}, {opts})"))
	118	+ "a" (unless epi (when (in cursor (get shapes 0))
	119	+ (setv epi (len shapes))
	120	+ (shapes.append {}))
	121	+ (setv message f"started shape {epi}")))
	122	+ (when epi
	123	+ (when (in cursor (get shapes 0)) (hop-shape cursor (get shapes 0) (get shapes epi)))
	124	+ (when (>= (len (get shapes epi)) WIDTH)
	125	+ (setv message f"completed shape {epi}")
	126	+ (when (.startswith (setx message (cond
	127	+ (let [MPW (-> WIDTH (math.sqrt) (* 2) (math.floor)) ns (normalise (get shapes epi))]
	128	+ (any (lfor p ns (>= (max (gx p) (gy p)) MPW))))
	129	+ "WRN: shape would be too elongated"
	130	+ (any (lfor s (cut shapes None -1) (equiv s (get shapes epi))))
	131	+ "WRN: shape would be a duplicate"
	132	+ (any (lfor c (components (get shapes 0)) (% (len c) WIDTH)))
	133	+ "ERR: shape would leave invalid-size parts"
	134	+ True message)) "ERR")
	135	+ (for [xy (list (get shapes epi))]
	136	+ (hop-shape xy (get shapes epi) (get shapes 0)))
	137	+ (shapes.pop))
	138	+ (setv epi 0)
	139	+ (for [xy (get shapes 0)]
	140	+ (when (= (len (get shapes 0 xy)) 1)
	141	+ (setv epi (len shapes))
	142	+ (shapes.append {})
	143	+ (setv opts [xy])
	144	+ (while (and
	145	+ (= (len opts) 1)
	146	+ (< (len (get shapes epi)) WIDTH))
	147	+ (setv cursor (get opts 0))
	148	+ (setx opts (list (get shapes 0 cursor)))
	149	+ (hop-shape cursor (get shapes 0) (get shapes epi)))
	150	+ (unless (message.startswith "ERR")
	151	+ (setv message f"inferred {(len (get shapes epi))} cells of forced shape {epi}"))
	152	+ (when (any (lfor comp (components (get shapes 0))
	153	+ (- (len (get shapes epi)) (% (len comp) WIDTH))))
	154	+ (setv message f"ERR: invalid-size parts forced?"))
	155	+ (break)))
	156	+ (unless (or epi (not (get shapes 0)) (in cursor (get shapes 0)))
	157	+ (setv cursor (next (iter (lfor x (range WIDTH) y (range WIDTH)
	158	+ :if (in #(x y) (get shapes 0)) #(x y))))))))
	159	+ (when (= (len (get shapes 0)) 0) (break))
	160	+ (for [#(i s) (enumerate shapes)]
	161	+ (draw stdscr s (get SHAPE-CHARS i)))
	162	+ (stdscr.addch (gy cursor) (gx cursor) "@")
	163	+ (stdscr.hline WIDTH 0 " " (get (stdscr.getmaxyx) 1))
	164	+ (stdscr.addstr WIDTH 0
	165	+ f"({(gx cursor)}, {(gy cursor)}) in poly {(try (get (lfor #(i s) (enumerate shapes) :if (in cursor s) i) 0) (except [IndexError] "?"))}{(if message (+ " \| " message) "")}")
	166	+ (setv k (stdscr.getch))))
	167	+
	168	+(defn load-shapes [fname]
	169	+ (setv fl (with [fh (open fname "r")]
	170	+ (lfor l (fh.readlines) :if (not (l.startswith "#")) (l.strip))))
	171	+ (setv WIDTH (len (get fl 0)))
	172	+ (setv shapes [(init-grid WIDTH WIDTH)])
	173	+ (for [#(y r) (enumerate fl) #(x c) (enumerate r) :if (.isdigit c)]
	174	+ (let [i (int c)]
	175	+ (when (<= (len shapes) i) (shapes.extend (lfor _ (range (- (inc i) (len shapes))) {})))
	176	+ (hop-shape #(x y) (get shapes 0) (get shapes i))))
	177	+ shapes)
	178	+
	179	+(try
	180	+ (setv mode (get sys.argv 1))
	181	+ (setv fname (get sys.argv 2))
	182	+ (cond
	183	+ (.isdigit mode) (do
	184	+ (setv WIDTH (int mode))
	185	+ (setv shapes [(init-grid WIDTH WIDTH)])
	186	+ (curses.wrapper builder)
	187	+ (setv og (draw "" #{#(0 0)} "_" "_" WIDTH WIDTH))
	188	+ (for [#(i s) (enumerate shapes)] (setv og (draw og s (str i) "_")))
	189	+ (with [fh (open fname "w")] (fh.write (+ (.join "\n" (lfor r og (.join "" r))) "\n"))))
	190	+ (= mode "q") (print (to-pbm (lfor s (load-shapes fname)
	191	+ :if s (rotate s (random.randrange 4)))))
	192	+ (= mode "a") (print (to-ppm (lfor s (load-shapes fname) :if s s))))
	193	+ (except [FileNotFoundError]
	194	+ (print f"{(get sys.argv 0)}: can't load from {fname}: No such file or directory")))
0	195