L-99 P98 再び

お絵かきロジックを、より人間らしく解く！

とは言っても、普通の人間には簡単にできる
・解法を自ら学習する
・新たな解法を発見する
とかは出来ません。

というか、そんなのが出来たら怖いです。

人類を敵と見做して核攻撃とかしそう！
人形ロボットを作って人類抹殺とか始めそう！！
親指立てて溶鉱炉に沈みそう！！！
マジ怖い！！！！（SF映画の見すぎですｗ)

・・・さて、まずは共通処理から。

(define nil '())

(define (enumerate-interval low high)
  (if (> low high)
      nil
      (cons low (enumerate-interval (+ low 1) high))))

(define (accumulate op initial seq)
  (if (null? seq)
      initial
      (op (car seq)
	  (accumulate op initial (cdr seq)))))

(define (flatmap proc seq)
  (accumulate append nil (map proc seq)))

(define (remove item seq)
  (filter (lambda (x) (not (eq? x item))) seq))

(define (permutations s c)
  (if (or (= c 0) (null? s))
      (list nil)
      (flatmap (lambda (x)
		 (map (lambda (p) (cons x p))
		      (permutations (remove x s) (- c 1))))
	       s)))

(define (repeated-permutations s n)
  (if (= n 0)
      (list nil)
      (flatmap (lambda (x)
		 (map (lambda (p) (cons x p)) (repeated-permutations s (- n 1))))
	       s)))

(define (uniq lis)
  (define ht (make-hash-table 'equal?))
  (define (iter l)
    (if (null? l)
	(hash-table-keys ht)
	(let ((key (hash-table-get ht (car l) nil)))
	  (and (null? key) (hash-table-put! ht (car l) (car l)))
	  (iter (cdr l)))))
  (iter lis))

お絵かきロジックを解くプログラム。

(define *matrix* nil)
(define *rows* 0)
(define *cols* 0)
(define *row-states* nil)
(define *col-states* nil)

(define (make-matrix r c)
  (make-s8vector (* r c) -1))

(define (matrix-set! r c val)
  (s8vector-set! *matrix* (+ (* r *cols*) c) val))

(define (matrix-ref r c)
  (s8vector-ref *matrix* (+ (* r *cols*) c)))

(define (matrix->list row-or-col idx)
  (define (iter i r c lis)
    (if (= i 0)
	lis
	(if (eq? row-or-col 'row)
	    (iter (- i 1) r (+ c 1) (append lis (cons (matrix-ref r c) nil)))
	    (iter (- i 1) (+ r 1) c (append lis (cons (matrix-ref r c) nil))))))
  (if (eq? row-or-col 'row)
      (iter *cols* idx 0 nil)
      (iter *rows* 0 idx nil)))

(define (matrix->sublist row-or-col idx pos)
  (define (iter p lis)
    (if (null? p)
	lis
	(if (eq? row-or-col 'row)
	    (iter (cdr p) (append lis (cons (matrix-ref idx (car p)) nil)))
	    (iter (cdr p) (append lis (cons (matrix-ref (car p) idx) nil))))))
  (iter pos nil))

;;

(define (matrix-debug)
  (define (iter-c r c)
    (if (= c *cols*)
	'done
	(begin
	  (matrix-set! r c (+ (* r 10) c))
	  (iter-c r (+ c 1)))))
  (define (iter-r r)
    (if (= r *rows*)
	'done
	(begin
	  (iter-c r 0)
	  (iter-r (+ r 1)))))
  (iter-r 0))

(define (print-matrix)
  (define (iter-c r c)
    (if (= c *cols*)
	'done
	(begin
	  (let ((val (matrix-ref r c)))
	    (if (= val -1)
		(display "_")
		(display val))
	    (display " ")
	    (iter-c r (+ c 1))))))

  (define (iter-r r)
    (if (= r *rows*)
	'done
	(begin
;;	  (display r)
;;	  (display " ")
	  (iter-c r 0)
	  (newline)
	  (iter-r (+ r 1)))))
;;  (display "  0 1 2 3 4 5 6 7")
;;  (newline)
  (iter-r 0))

;;

(define (init row-states col-states)
  (set! *row-states* row-states)
  (set! *col-states* col-states)
  (set! *rows* (length row-states))
  (set! *cols* (length col-states))
  (set! *matrix* (make-matrix *rows* *cols*))
  )

(define (get-state row-or-col i)
  (if (eq? row-or-col 'row)
      (list-ref *row-states* i)
      (list-ref *col-states* i)))

(define (state->list state)
  (define (iter n lst result)
    (if (null? lst)
	result
	(iter (+ n 1) (cdr lst) (append result (if (null? result) nil '(0)) (make-list (car lst) n)))))
  (iter 1 state nil))

(define (matrix-set-list! row-or-col row col lst)
  (define (iter l r c)
    (if (null? l)
	'done
	(if (or (>= r *rows*) (>= c *cols*))
	    (error (format #f "OUT OF MATRIX r=~d c=~d" r c))
	    (begin
	      ;; for debug
	      ;;(matrix-set! r c (car l))
	      (and (= (matrix-ref r c) -1) (matrix-set! r c (if (>= (car l) 1) 1 0)))
	      (iter (cdr l)
		    (if (eq? row-or-col 'col) (+ r 1) r)
		    (if (eq? row-or-col 'row) (+ c 1) c))))))
  (iter lst row col))

(define (total-state state)
  (+ (apply + state) (- (length state) 1)))

(define (find-masu lst pred)
  (define (iter l i result1 result2)
    (if (null? l)
	(if (null? result1)
	    result2
	    (append result2 `(,result1)))
	(if (pred (car l))
	    (iter (cdr l) (+ i 1) (append result1 (cons i nil)) result2)
	    (iter (cdr l) (+ i 1) nil (if (null? result1) result2 (append result2 `(,result1))))
	    )))
  (iter lst 0 nil nil))

(define (find-kuromasu lst)
  (find-masu lst (lambda (x) (= x 1))))

(define (find-mi-kakutei lst)
  (find-masu lst (lambda (x) (= x -1))))

(define (find-kuro-and-mi-kakutei lst)
  (find-masu lst (lambda (x) (not (= x 0)))))

(define (find-shiro lst)
  (find-masu lst (lambda (x) (= x 0))))

;; 部分確定  (左右につめた時に生じる共通の黒マスを処理する。白マスがある場合は処理する範囲を狭める。)
(define (bubun-kakutei row-or-col index)
  (define (bubun-kakutei-main row-or-col index nakami-list)
    (define (kaburi-state row-or-col index pos left-state right-state)
      (define (iter left right i)
	(if (null? left)
	    'done
	    (begin 
	      (and (> (car left) 0) (> (car right) 0) (= (car left) (car right))
		   (if (eq? row-or-col 'row)
		       (matrix-set! index i 1)
		       (matrix-set! i index 1)))
	      (iter (cdr left) (cdr right) (+ i 1)))))
      (iter left-state right-state pos))
  
    (define (make-state-list row-or-col left-or-right state-list matrix-list)
      (let ((husoku (- (length matrix-list) (length state-list))))
	(if (eq? left-or-right 'left)
	    (append (make-list husoku 0) state-list)
	    (append state-list (make-list husoku 0)))))

    (if (eq? row-or-col 'row)
	(let ((state (get-state 'row index)))
	  (and (> (total-state state) (floor (/ (length nakami-list) 2)))
	       (let* ((state-list (state->list state))
		      (left (make-state-list 'row 'left state-list nakami-list))
		      (right (make-state-list 'row 'right state-list nakami-list)))
		 (kaburi-state row-or-col index (car nakami-list) left right))))
	(let ((state (get-state 'column index)))
	  (and (> (total-state state) (floor (/ (length nakami-list) 2)))
	       (let* ((state-list (state->list state))
		      (left (make-state-list 'column 'left state-list nakami-list))
		      (right (make-state-list 'column 'right state-list nakami-list)))
		 (kaburi-state row-or-col index (car nakami-list) left right))))
	))

  (let* ((matrix-list (matrix->list row-or-col index))
	 (nakami-list (find-kuro-and-mi-kakutei matrix-list)))
    (and (= (length nakami-list) 1)
	 (bubun-kakutei-main row-or-col index (car nakami-list)))
    ))

;;

(define (solve-1)
  ; 最高値を処理
  (define (kakutei row-or-col index)
    (if (eq? row-or-col 'row)
	(let ((state (get-state 'row index)))
	  (and (= (total-state state) *cols*)
	       (matrix-set-list! 'row index 0 (state->list state))))
	(let ((state (get-state 'col index)))
	  (and (= (total-state state) *rows*)
	       (matrix-set-list! 'col 0 index (state->list state))))))
  
  (define (iter-r r)
    (if (= r *rows*)
	'done
	(begin
	  (kakutei 'row r)
	  (bubun-kakutei 'row r)
	  (iter-r (+ r 1)))))

  (define (iter-c c)
    (if (= c *cols*)
	'done
	(begin
	  (kakutei 'col c)
	  (bubun-kakutei 'col c)
	  (iter-c (+ c 1)))))
  
  (iter-r 0)
  (iter-c 0))

(define (solve-2)
  ;; 列が確定したか調べる
  (define (kakutei? row-or-col index)
    (= (length (filter (lambda (x) (= x -1)) (matrix->list row-or-col index))) 0))

  ;; 全黒マス、全白マスが確定した列の処理
  (define (kakutei row-or-col index)
    (define (umeru-zero row-or-col index matrix-list)
      (let ((mat-lis (map (lambda (x) (if (= x -1) 0 x)) matrix-list)))
	(if (eq? row-or-col 'row)
	    (matrix-set-list! 'row index 0 mat-lis)
	    (matrix-set-list! 'col 0 index mat-lis))))
    
    (let* ((state (get-state row-or-col index))
	   (matrix-list (matrix->list row-or-col index))
	   (kakutei-su (length (filter (lambda (x) (= x 1)) matrix-list))))
;      (print ";;kakutei row-or-col=" row-or-col " index=" index " state=" state " matrix-list=" matrix-list " kakutei-su=" kakutei-su)
      (and (= (apply + state) kakutei-su)
	   (umeru-zero row-or-col index matrix-list))))

  ;; 黒マスの両隣を埋める処理
  (define (kuromasu row-or-col index)
    (define (find-state matrix-list state)
      (define (search-list lis1 lis2)
	(define (iter-2 st ed lis)
	  (if (null? lis)
	      st
	      (if (= (list-ref lis1 ed) (car lis))
		  (iter-2 st (+ ed 1) (cdr lis))
		  #f)))
	(define (iter-1 st)
	  (if (> st (- (length lis1) (length lis2)))
	      #f
	      (or (iter-2 st st lis2) (iter-1 (+ st 1)))))
	(iter-1 0))
      (search-list matrix-list (make-list state 1)))
    
    (define (kuromasu-zero row-or-col index st-pos ed-pos)
      (and (> st-pos 0) (< ed-pos (- (if (eq? row-or-col 'row) *cols* *rows*) 1))
	   (let ((st (- st-pos 1))
		 (ed (+ ed-pos 1)))
	     (if (eq? row-or-col 'row)
		 (begin
		   (and (= (matrix-ref index st) -1) (matrix-set! index st 0))
		   (and (= (matrix-ref index ed) -1) (matrix-set! index ed 0)))
		 (begin
		   (and (= (matrix-ref st index) -1) (matrix-set! st index 0))
		   (and (= (matrix-ref ed index) -1) (matrix-set! ed index 0)))))))
  
    (let* ((max-state (apply max (get-state row-or-col index)))
	   (matrix-list (matrix->list row-or-col index)))
      (let ((start-pos (find-state matrix-list max-state)))
	(and start-pos
	     (kuromasu-zero row-or-col index start-pos (+ start-pos max-state -1))))))

  ;; 端の処理
  (define (hashi row-or-col index)
    (let ((state (get-state row-or-col index))
	  (matrix-list (matrix->list row-or-col index)))
;;      (print ";;row-or-col=" row-or-col " index=" index " matrix-list=" matrix-list)
      (if (= (car matrix-list) 1)
	  (let ((state-list (append (make-list (car state) 1) '(0))))
	    (if (eq? row-or-col 'row)
		(matrix-set-list! row-or-col index 0 state-list)
		(matrix-set-list! row-or-col 0 index state-list))))
      (if (= (last matrix-list) 1)
	  (let ((state-list (append '(0) (make-list (last state) 1))))
	    (if (eq? row-or-col 'row)
		(matrix-set-list! row-or-col index (- *cols* (length state-list)) state-list)
		(matrix-set-list! row-or-col (- *rows* (length state-list)) index state-list))))
      ))

  ;; 端の処理 (白マスで分割される場合を考慮する)
  (define (bubun-hashi row-or-col index pos state matrix-list)
    (define (make-state-list left-or-right)
      (if (eq? left-or-right 'left)
	  (if (> (length matrix-list) state)
	      (append (make-list state 1) '(0))
	      (make-list state 1))
	  (if (> (length matrix-list) state)
	      (append '(0) (make-list state 1))
	      (make-list state 1))))

    (if (< (length matrix-list) state)
	'done
	(begin
	  (if (= (car matrix-list) 1)
	      (let ((state-list (make-state-list 'left)))
;;		(print ";;111 index=" index " matrix-list=" matrix-list " pos=" pos " state=" state " state-list=" state-list)
		(if (eq? row-or-col 'row)
		    (matrix-set-list! row-or-col index pos state-list)
		    (matrix-set-list! row-or-col pos index state-list))))
	  (if (= (last matrix-list) 1)
	      (let ((state-list (make-state-list 'right)))
;;		(print ";;222 index=" index " matrix-list=" matrix-list " pos=" pos " state=" state " state-list=" state-list)
		(if (eq? row-or-col 'row)
		    (matrix-set-list! row-or-col index (+ pos (- (length matrix-list) (length state-list))) state-list)
		    (matrix-set-list! row-or-col (+ pos (- (length matrix-list) (length state-list))) index state-list)))))))

  ;; 狭小マスの処理
  (define (kyosho row-or-col index)
    (define (nagasa lst)
      (define (iter l i st len result)
	(if (null? l)
	    (if (> len 0)
		(append result (cons (cons st len) nil))
		result)
	    (if (= (car l) 0)
		(iter (cdr l)
		      (+ i 1)
		      (+ i 1)
		      0
		      (if (> len 0) (append result (cons (cons st len) nil)) result))
		(iter (cdr l)
		      (+ i 1)
		      st
		      (+ len 1)
		      result))))
      (iter lst 0 0 0 nil))
    
    (define (umeru-kyosho row-or-col index state nagasa-list)
      (define (iter lst)
	(if (null? lst)
	    'done
	    (let ((st (caar lst))
		  (len (cdar lst)))
	      (and (< len state)
		   (if (eq? row-or-col 'row)
		       (matrix-set-list! row-or-col index st (make-list len 0))
		       (matrix-set-list! row-or-col st index (make-list len 0))))
	      (iter (cdr lst)))))
      (iter nagasa-list))
    
    (let ((states (get-state row-or-col index)))
      (if (> (length states) 1)
	  'done
	  (let* ((matrix-list (matrix->list row-or-col index))
		 (nagasa-list (nagasa matrix-list)))
	    (umeru-kyosho row-or-col index (car states) nagasa-list)))))

  ;; 確実に黒マスが届くマス、届かないマスを処理
  (define (todoku row-or-col index)
    (define (todoku-1 row-or-col index state kuro-index)
      (let ((l (- (last kuro-index) state))
	    (r (+ (car kuro-index) state)))
	
;;      (print ";;row-or-col=" row-or-col " index=" index " state=" state " kuro-index=" kuro-index)
;;      (print ";;l=" l " r=" r)
	(let ((max-index (if (eq? row-or-col 'row) *cols* *rows*)))
	  (if (eq? row-or-col 'row)
	      (begin
		(and (>= l 0) (matrix-set-list! row-or-col index 0 (make-list (+ l 1) 0)))
		(and (< r max-index) (matrix-set-list! row-or-col index r (make-list (- max-index r) 0))))
	      (begin
		(and (>= l 0) (matrix-set-list! row-or-col 0 index (make-list (+ l 1) 0)))
		(and (< r max-index) (matrix-set-list! row-or-col r index (make-list (- max-index r) 0))))
	      ))))
  
    (let ((states (get-state row-or-col index)))
      (if (> (length states) 1)
	  'done
	  (let* ((matrix-list (matrix->list row-or-col index))
		 (kuro (find-kuromasu matrix-list)))
	    (and (not (null? kuro)) (= (length kuro) 1) (todoku-1 row-or-col index (car states) (car kuro)))
	    ))))

  ;; 最高値の更新に対する処理
  (define (kakutei-2 row-or-col index)
    (define (kakutei-2? states mi-kakutei-list)
      (define (iter s lst)
	(if (null? s)
	    #t
	    (if (not (= (car s) (length (car lst))))
		#f
		(iter (cdr s) (cdr lst)))))
      (if (= (length states) (length mi-kakutei-list))
	  (iter states mi-kakutei-list)
	  #f))

    (define (kaku-2 row-or-col index mi-kakutei-list)
      (define (iter lst)
	(if (null? lst)
	    'done
	    (let* ((elem (car lst))
		   (st (car elem))
		   (len (length elem)))
	      (if (eq? row-or-col 'row)
		  (matrix-set-list! row-or-col index st (make-list len 1))
		  (matrix-set-list! row-or-col st index (make-list len 1)))
	      (iter (cdr lst)))))
      (iter mi-kakutei-list))
    
    (let* ((states (get-state row-or-col index))
	   (matrix-list (matrix->list row-or-col index))
	   (kuro-list (find-kuromasu matrix-list))
	   (mi-kakutei-list (find-kuro-and-mi-kakutei matrix-list)))
;;      (print ";;kakutei-2 row-or-col=" row-or-col " index=" index " matrix-list=" matrix-list " kuro-list=" kuro-list " mi-kakutei-list=" mi-kakutei-list)
      (and (kakutei-2? states mi-kakutei-list)
	   (kaku-2 row-or-col index mi-kakutei-list))))

  ;; 0 で分割されている場合に範囲を狭めて確定する処理
  (define (kakutei-3 row-or-col index)
    (define (iter sub-pos states)
      (if (or (null? sub-pos) (null? states))
	  'done
	  (begin
	    (bubun-hashi row-or-col index (caar sub-pos) (car states) (matrix->sublist row-or-col index (car sub-pos)))
	    (iter (cdr sub-pos) (cdr states)))))
    (let* ((states (get-state row-or-col index))
	   (matrix-list (matrix->list row-or-col index)))
;;      (print ";; kakutei-3 row-or-col=" row-or-col " index=" index " states=" states " matrix-list=" matrix-list)
      (and (= (length (filter (lambda (x) (= x 0)) matrix-list)) 1)
	   (iter (find-kuro-and-mi-kakutei matrix-list) states))))

  ;; 端から 0 が続いて 1 が表われる場合に確定する処理 (端に 0 が無くても処理可能)
  (define (kakutei-4 row-or-col index)
    (define (ryo-hashi-shiro? row-or-col lst)
      (define (mae l i)
	(if (null? l)
	    #t
	    (if (> (car l) i)
		#f
		(mae (cdr l) (+ i 1)))))
      (define (ushiro l i)
	(if (null? l)
	    #t
	    (if (< (car l) i)
		#f
		(ushiro (cdr l) (- i 1)))))
      (if (or (null? lst) (not (= (length lst) 2)))
	  #f
	  (begin
	    (and (mae (car lst) 0) (ushiro (reverse (cadr lst)) (- (if (eq? row-or-col 'row) *cols* *rows*) 1)))
	    )))
    
    (let* ((states (get-state row-or-col index))
	   (matrix-list (matrix->list row-or-col index))
	   (shiro-list (find-shiro matrix-list))
	   (nakami-list (find-kuro-and-mi-kakutei matrix-list)))
;;      (print ";;; matrix-list=" matrix-list)
;;      (print ";;; shiro-list=" shiro-list)
      (if (ryo-hashi-shiro? row-or-col shiro-list)
	  (begin
;;	    (print ";; ryouhashi ha shiro !")
;;	    (print ";; shiro-list=" shiro-list)
;;	    (print ";; nakami-list=" nakami-list)
	    (bubun-hashi row-or-col index (caar nakami-list) (car states) (matrix->sublist row-or-col index (car nakami-list)))))))

  (define (iter-r r)
    (if (= r *rows*)
	'done
	(begin
	  (if (not (kakutei? 'row r))
	      (begin
		(kakutei 'row r)
		(kuromasu 'row r)
		(hashi 'row r)
		(kyosho 'row r)
		(todoku 'row r)
		(kakutei-2 'row r)
		(kakutei-3 'row r)
		(kakutei-4 'row r)
		(bubun-kakutei 'row r)
		))
	  (iter-r (+ r 1)))))

  (define (iter-c c)
    (if (= c *cols*)
	'done
	(begin
	  (if (not (kakutei? 'col c))
	      (begin
		(kakutei 'col c)
		(kuromasu 'col c)
		(hashi 'col c)
		(kyosho 'col c)
		(todoku 'col c)
		(kakutei-2 'col c)
		(kakutei-3 'col c)
		(kakutei-4 'col c)
		(bubun-kakutei 'col c)
		))
	  (iter-c (+ c 1)))))

  ;; パズルが出来たか調べる
  (define (dekita?)
    (= (length (filter (lambda (x) (= x -1)) (s8vector->list *matrix*))) 0))
  
  (define (iter phase)
    (if (dekita?)
	'done
	(begin
	  (iter-r 0)
	  (iter-c 0)
;;	  (print ";; ===== solve-2 phase=" phase " =====")
;;	  (print-matrix)
	  (iter (+ phase 1)))))

  (iter 1))

(define (nonograms row-states column-states)
  (init row-states column-states)
  (solve-1)
  (solve-2)
  (print-matrix)
  )

コードが汚い！とにかく汚い！
手続き名がローマ字読みｗｗｗ

解法のロジックはウィキペディアを参考にしました。
なお、第三段階は未実装です。
列毎の黒マスの数が３個以上の場合に正常に動くかはテストしていませんｗ

結果

gosh> (time (nonograms '((3) (2 1) (3 2) (2 2) (6) (1 5) (6) (1) (2)) '((1 2) (3 1) (1 5) (7 1) (5) (3) (4) (3))))
0 1 1 1 0 0 0 0 
1 1 0 1 0 0 0 0 
0 1 1 1 0 0 1 1 
0 0 1 1 0 0 1 1 
0 0 1 1 1 1 1 1 
1 0 1 1 1 1 1 0 
1 1 1 1 1 1 0 0 
0 0 0 0 1 0 0 0 
0 0 0 1 1 0 0 0 
;(time (nonograms '((3) (2 1) (3 2) (2 2) (6) (1 5) (6) (1) (2)) '((1 2) ...
; real   0.000
; user   0.000
; sys    0.000
done

処理時間についてですが、ミリ秒のオーダーでは計れません。
総当たり解法よりも圧倒的に速いです。