--- /dev/null
+(defpackage :sudoku-gui
+ (:use :clim-lisp :clim))
+
+(defpackage :sudoku-algorithm
+ (:use :clim-lisp :clim))
--- /dev/null
+(in-package :sudoku-algorithm)
+
+(defparameter *board-width* 9)
+(defparameter *board* (make-array (list *board-width* *board-width*)))
+(defparameter *row-unit* 0)
+(defparameter *column-unit* 1)
+(defparameter *square-unit* 2)
+
+;;; This class represents units that contain an array of cells.
+;;; A unit can include cells in a row of Sudoku board,
+;;; cells in a column of board, or cells in a square of board.
+(defclass unit ()
+ ((%cells :initarg :cells :accessor cells)))
+
+(defun make-unit ()
+ (make-instance 'unit :cells (make-array *board-width*)))
+
+;;; This class represents cells that contain possible values.
+;;; These cells also contain an array of units to which they belong.
+(defclass cell ()
+ ((%parents :initarg :parents :accessor parents)
+ (%possibilities :initarg :possibilities :accessor possibilities)))
+
+(defun make-cell ()
+ (make-instance 'cell
+ :parents (make-array 3)
+ :possibilities (make-array *board-width* :element-type 'bit :initial-element 1)))
+
+(defun erase-possibilities (cell)
+ (let* ((leng (length (possibilities cell)))
+ (tmp (make-array leng :element-type 'bit :initial-element 0)))
+ (setf (possibilities cell) tmp)))
+
+(defun set-possibilities (cell index value)
+ (setf (aref (possibilities cell) index) value))
+
+(defun check-hole (cell)
+ (if (= (symbolset-cardinality (possibilities cell)) 1)
+ (return-from check-hole nil))
+ t)
+
+(defun find-possibilities (cell)
+ (let ((tmp (make-array *board-width* :element-type 'bit :initial-element 1)))
+ (loop for unit across (parents cell)
+ do (loop for cell1 across (cells unit)
+ do (unless (check-hole cell1)
+ (let ((order-1 (position 1 (possibilities cell1))))
+ (setf (aref tmp order-1) 0)))))
+ (setf (possibilities cell) tmp)))
+
+;;; This class represents a Sudoku board.
+;;; It includes an array of symbols that is used to display characters,
+;;; an array of cells in the board,
+;;; and an array of all units (row-units, column-units, square-units).
+(defclass game ()
+ ((%symbols :initarg :symbols :accessor symbols)
+ (%cells :initarg :cells :accessor cells)
+ (%units :initarg :units :accessor units)))
+
+(defun make-game ()
+ (make-instance 'game
+ :symbols (make-array *board-width*)
+ :cells (make-array (list *board-width* *board-width*))
+ :units (make-array (list 3 *board-width*))))
+
+(defparameter *game* (make-game))
+(defparameter *unit* (make-unit))
+
+(defun create-mapping-vector (game)
+ (let* ((board-width (array-dimension (cells game) 0))
+ (v (make-array board-width)))
+ (loop for i from 0 below board-width
+ do (setf (aref v i) (1+ i)))
+ ;;(shuffle-vector v) This statement is commented for easy checking
+ (setf (symbols game) v)))
+
+(defun map-over-rectangle (fun game start-row height start-col width)
+ (loop for row from start-row
+ repeat height
+ do (loop for col from start-col
+ repeat width
+ do (funcall fun (aref (cells game) row col)))))
+
+(defun copy-rectangle-to-unit (game start-row height start-col width unit)
+ (let ((unit-index -1))
+ (map-over-rectangle (lambda (cell) (setf (aref (cells unit) (incf unit-index)) cell))
+ game start-row height start-col width)))
+
+(defun set-parents-of-cell (unit type)
+ (loop for cell across (cells unit)
+ do (setf (aref (parents cell) type) unit)))
+
+(defun symbolset-cardinality (symbolset)
+ (count 1 symbolset))
+
+(defun symbolset-union (symbolset1 symbolset2)
+ (bit-ior symbolset1 symbolset2))
+
+(defun symbolset-difference (symbolset1 symbolset2)
+ (bit-andc2 symbolset1 symbolset2))
+
+(defun create-sample-unit (unit choice)
+ (let ((unit1 (make-unit))
+ (unit2 (make-unit))
+ (unit3 (make-unit)))
+ (loop for i from 0 below *board-width*
+ do (let ((cell (make-cell)))
+ (erase-possibilities cell)
+ (set-possibilities cell i 1)
+ (setf (aref (cells unit1) i) cell)))
+ (setf (possibilities (aref (cells unit1) 3)) #*000110000)
+ (loop for i from 0 below *board-width*
+ do (let ((cell (make-cell)))
+ (setf (possibilities cell) #*111111000)
+ (setf (aref (cells unit2) i) cell)))
+ (setf (possibilities (aref (cells unit2) 3)) #*000001100)
+ (setf (possibilities (aref (cells unit2) 5)) #*000001010)
+ (loop for i from 0 below *board-width*
+ do (let ((cell (make-cell)))
+ (setf (possibilities cell) #*111111000)
+ (setf (aref (cells unit3) i) cell)))
+ (setf (possibilities (aref (cells unit3) 3)) #*001000000)
+ (setf (possibilities (aref (cells unit3) 5)) #*000010000)
+ (cond ((= choice 1) (setf (cells unit) (cells unit1)))
+ ((= choice 2) (setf (cells unit) (cells unit2)))
+ ((= choice 3) (setf (cells unit) (cells unit3))))))
+
+(defun strategy1 (unit)
+ (let ((result '())
+ (ambiguous-cells
+ (remove-if-not
+ (lambda (cell) (equalp (check-hole cell) t))
+ (cells unit))))
+ (if (= (length ambiguous-cells) 1)
+ ;; then the strategy is applicable
+ (let ((cell (aref ambiguous-cells 0)))
+ (setf (possibilities cell)
+ (symbolset-difference (possibilities cell)
+ (reduce #'symbolset-union
+ (remove cell (cells unit))
+ :key #'possibilities)))
+ (push cell result)))
+ result))
+
+(defun strategy2 (unit)
+ (let ((result '())
+ (ambiguous-cells
+ (remove-if-not
+ (lambda (cell) (equalp (check-hole cell) t))
+ (cells unit))))
+ (loop for cell across ambiguous-cells
+ do (let ((diff (symbolset-difference (possibilities cell)
+ (reduce #'symbolset-union
+ (remove cell (cells unit))
+ :key #'possibilities))))
+ (when (= (symbolset-cardinality diff) 1)
+ (setf (possibilities cell) diff)
+ (push cell result))))
+ result))
+
+(defun strategy3 (unit)
+ (let ((result '())
+ (ambiguous-cells
+ (remove-if-not
+ (lambda (cell) (equalp (check-hole cell) t))
+ (cells unit)))
+ (unhole-cells
+ (remove-if
+ (lambda (cell) (equalp (check-hole cell) t))
+ (cells unit))))
+ (loop for cell across unhole-cells
+ do (let ((order-1 (position 1 (possibilities cell))))
+ (loop for hole across ambiguous-cells
+ do (when (= (aref (possibilities hole) order-1) 1)
+ (set-possibilities hole order-1 0)
+ (push hole result)))))
+ result))
+
+(defun create-initial-board (board)
+ (let* ((board-width (array-dimension board 0))
+ (sqrt-board-width (isqrt board-width)))
+ (loop for offset1 from 0 below sqrt-board-width
+ for block-start from 0 below board-width by sqrt-board-width
+ do (loop for row from block-start
+ for offset2 from 0 by sqrt-board-width
+ repeat sqrt-board-width
+ do (loop for col from 0 below board-width
+ do (setf (aref board row col)
+ (mod (+ col offset1 offset2) board-width)))))))
+
+;;; Exchange two non-overlapping rectangles having the same shape
+(defun exchange-rectangles (board start-row-1 start-col-1 height width start-row-2 start-col-2)
+ (unless (and (= start-row-1 start-row-2) (= start-col-1 start-col-2))
+ (loop for row-1 from start-row-1
+ for row-2 from start-row-2
+ repeat height
+ do (loop for col-1 from start-col-1
+ for col-2 from start-col-2
+ repeat width
+ do (rotatef (aref board row-1 col-1)
+ (aref board row-2 col-2))))))
+
+(defun exchange-rows (board row-1 row-2)
+ (let ((board-width (array-dimension board 0)))
+ (exchange-rectangles board row-1 0 1 board-width row-2 0)))
+
+(defun exchange-columns (board col-1 col-2)
+ (let ((board-height (array-dimension board 1)))
+ (exchange-rectangles board 0 col-1 board-height 1 0 col-2)))
+
+(defun exchange-blocks-of-rows (board row-1 row-2)
+ (let* ((board-width (array-dimension board 0))
+ (sqrt-board-width (isqrt board-width)))
+ (exchange-rectangles board row-1 0 sqrt-board-width board-width row-2 0)))
+
+(defun exchange-blocks-of-columns (board col-1 col-2)
+ (let* ((board-width (array-dimension board 0))
+ (sqrt-board-width (isqrt board-width)))
+ (exchange-rectangles board 0 col-1 board-width sqrt-board-width 0 col-2)))
+
+(defun compute-random-permutation (n exchange-fun)
+ (loop for i from 0 to (- n 2)
+ do (let ((e (+ i (random (- n i)))))
+ (unless (= i e)
+ (funcall exchange-fun i e)))))
+
+(defun shuffle-vector (vector)
+ (let ((N (length vector)))
+ (compute-random-permutation
+ N (lambda (i j) (rotatef (aref vector i) (aref vector j))))))
+
+(defun shuffle-rows-within-block (board block-start)
+ (let ((N (isqrt (array-dimension board 0))))
+ (compute-random-permutation
+ N (lambda (r1 r2) (exchange-rows board (+ block-start r1) (+ block-start r2))))))
+
+(defun shuffle-columns-within-block (board block-start)
+ (let ((N (isqrt (array-dimension board 0))))
+ (compute-random-permutation
+ N (lambda (c1 c2) (exchange-columns board (+ block-start c1) (+ block-start c2))))))
+
+(defun shuffle-blocks-of-rows (board)
+ (let ((N (isqrt (array-dimension board 0))))
+ (compute-random-permutation
+ N (lambda (r1 r2) (exchange-blocks-of-rows board (* r1 N) (* r2 N))))))
+
+(defun shuffle-blocks-of-columns (board)
+ (let ((N (isqrt (array-dimension board 0))))
+ (compute-random-permutation
+ N (lambda (c1 c2) (exchange-blocks-of-columns board (* c1 N) (* c2 N))))))
+
+(defun shuffle-board (board)
+ (let* ((board-width (array-dimension board 0))
+ (sqrt-board-width (isqrt board-width)))
+ (loop for block-start from 0 below board-width by sqrt-board-width
+ do (shuffle-rows-within-block board block-start))
+ (loop for block-start from 0 below board-width by sqrt-board-width
+ do (shuffle-columns-within-block board block-start))
+ (shuffle-blocks-of-rows board)
+ (shuffle-blocks-of-columns board)))
+
+(defun set-sample-game (game)
+ (let ((easy-board
+ (make-array (list *board-width* *board-width*)
+ :initial-contents '((0 6 5 0 2 0 0 7 0)
+ (7 2 9 5 3 0 0 0 0)
+ (0 4 0 8 0 0 2 0 9)
+ (0 5 1 0 8 0 7 0 2)
+ (0 0 0 7 0 2 0 0 0)
+ (2 0 7 0 4 0 3 9 0)
+ (6 0 4 0 0 1 0 2 0)
+ (0 0 0 0 9 8 6 3 7)
+ (0 9 0 0 6 0 1 4 0))))
+ (hard-board
+ (make-array (list *board-width* *board-width*)
+ :initial-contents '((0 0 0 3 0 8 0 5 4)
+ (8 5 0 6 9 0 0 0 0)
+ (2 0 0 0 4 0 0 8 0)
+ (6 0 0 0 0 0 7 0 1)
+ (7 2 0 0 0 0 0 4 5)
+ (3 0 5 0 0 0 0 0 2)
+ (0 7 0 0 5 0 0 0 3)
+ (0 0 0 0 8 6 0 2 9)
+ (4 6 0 9 0 3 0 0 0))))
+ (used-board (make-array (list *board-width* *board-width*))))
+ (setf used-board easy-board)
+ (loop for row from 0 below *board-width*
+ do (loop for col from 0 below *board-width*
+ for value = (aref used-board row col)
+ do (when (> value 0)
+ (erase-possibilities (aref (cells game) row col))
+ (set-possibilities (aref (cells game) row col) (- value 1) 1))))))
+
+(defun create-game (board)
+ (let* ((board-width (array-dimension board 0))
+ (sqrt-board-width (isqrt board-width))
+ (game (make-game)))
+ ;; Create an array of cell instances
+ (loop for row from 0 below board-width
+ do (loop for col from 0 below board-width
+ do (setf (aref (cells game) row col) (make-cell))))
+ (set-sample-game game)
+ ;; Create unit instances corresponding to rows
+ (loop for row from 0 below board-width
+ for unit = (aref (units game) *row-unit* row)
+ do (setf unit (make-unit))
+ (copy-rectangle-to-unit game row 1 0 board-width unit)
+ (set-parents-of-cell unit *row-unit*))
+ ;; Create unit instances corresponding to columns
+ (loop for col from 0 below board-width
+ for unit = (aref (units game) *column-unit* col)
+ do (setf unit (make-unit))
+ (copy-rectangle-to-unit game 0 board-width col 1 unit)
+ (set-parents-of-cell unit *column-unit*))
+ ;; Create unit instances corresponding to small squares
+ (let ((i -1))
+ (loop for row from 0 below board-width by sqrt-board-width
+ do (loop for col from 0 below board-width by sqrt-board-width
+ for unit = (aref (units game) *square-unit* (incf i))
+ do (setf unit (make-unit))
+ (copy-rectangle-to-unit game row sqrt-board-width col sqrt-board-width unit)
+ (set-parents-of-cell unit *square-unit*))))
+ (setf *game* game)))
+
+(defun solve-partial-board (game)
+ (let ((board-width (array-dimension (cells game) 0)))
+ (loop for row from 0 below board-width
+ do (loop for col from 0 below board-width
+ for cell = (aref (cells game) row col)
+ do (when (check-hole cell)
+ (find-possibilities cell))))
+ (format t "~%First game")
+ (print-board game)
+ (loop for i from 1 to 2
+ do (format t "~%Step ~S" i)
+ (print-board game))
+ (strategy1 (aref (units game) *square-unit* 8))))
+
+(defun print-board (game)
+ (let ((board-width (array-dimension (cells game) 0)))
+ (create-mapping-vector game)
+ (loop for row from 0 below board-width
+ do (format t "~%")
+ (loop for col from 0 below board-width
+ for cell = (aref (cells game) row col)
+ do (if (check-hole cell)
+ (format t "- ")
+ (let ((order-1 (position 1 (possibilities cell))))
+ (format t "~S " (aref (symbols game) order-1))))))))
+
+(defun main ()
+ (create-initial-board *board*)
+ (create-game *board*)
+ (solve-partial-board *game*))
+
+(defun test-strategy ()
+ (create-sample-unit *unit* 3)
+ (loop for i from 0 below *board-width*
+ do (describe (aref (cells *unit*) i)))
+ (strategy3 *unit*))
--- /dev/null
+(in-package :sudoku-gui)
+
+;;; Using presentations and presentation types to draw sudoku board.
+
+;;; This class represents cells that display values.
+;;; These cells can not be modified.
+(defclass fixed-cell ()
+ ((%label :initarg :name :reader label)
+ (%duplication :initarg :name :accessor duplication)))
+
+(defun make-fixed-cell (label)
+ (make-instance 'fixed-cell :name label))
+
+;;; This class represents cells those right values are hidden.
+;;; They can be modified by users.
+(defclass hole ()
+ ((%label :initarg :name :accessor label)
+ (%duplication :initarg :name :accessor duplication)))
+
+(defun make-hole (label)
+ (make-instance 'hole :name label))
+
+;;; This class represents cells that display the inputting-values.
+;;; They can not be modified by users.
+(defclass sudoku-symbol ()
+ ((%label :initarg :name :reader label)))
+
+(defun make-sudoku-symbol (label)
+ (make-instance 'sudoku-symbol :name label))
+
+(defparameter *board-size* 9)
+(defparameter *cell-width* 35)
+(defparameter *thin-line-width* 2)
+(defparameter *thick-line-width* 4)
+(defparameter *initial-x* 30)
+(defparameter *initial-y* 50)
+(defparameter *hole-to-be-changed* NIL)
+(defparameter *temp-array-to-display*
+ (make-array (list 9 9)
+ :initial-contents '((3 nil nil 1 nil nil 8 2 nil)
+ (nil nil nil nil nil nil 6 nil 9)
+ (nil 7 nil nil 6 nil nil nil nil)
+ (nil 3 nil nil 1 8 nil nil nil)
+ (nil 1 nil nil nil 9 nil nil 7)
+ (nil nil nil nil nil nil nil 9 8)
+ (6 nil nil nil 5 nil nil nil nil)
+ (8 2 nil nil nil nil 7 nil 4)
+ (nil nil 1 nil nil nil nil nil nil))))
+(defparameter *labels-list* NIL)
+
+(defun make-gui-array (board-size)
+ (let ((array (make-array (list board-size board-size))))
+ (dotimes (r board-size)
+ (dotimes (c board-size)
+ (setf (aref array r c)
+ (if (= r c)
+ (make-hole (format nil "~a~a" r c))
+ (make-fixed-cell (format nil "~a~a" r c))))))
+ array))
+
+(defun make-gui-array-2 (array-to-display)
+ (let ((array (make-array (list 9 9 ))))
+ (loop for r from 0 below 9
+ do (loop for c from 0 below 9
+ do (setf (aref array r c)
+ (if (equal (aref array-to-display r c)
+ nil)
+ (make-hole (format nil ""))
+ (make-fixed-cell
+ (format nil "~a"
+ (aref array-to-display r c)))))))
+ array))
+
+(defun make-sudoku-symbol-array (board-size)
+ (let ((array (make-array (list board-size))))
+ (loop for i from 0 below board-size
+ do (setf (aref array i)
+ (make-sudoku-symbol (format nil "~a" (+ i 1)))))
+ array))
+
+;;(defparameter *gui-array* (make-gui-array *board-size*))
+(defparameter *gui-array* (make-gui-array-2 *temp-array-to-display*))
+(defparameter *sudoku-symbol* (make-sudoku-symbol-array *board-size*))
+
+(defun search-pos (board-size gui-array item)
+ (let ((array-pos))
+ (loop for r from 0 below board-size
+ do (loop for c from 0 below board-size
+ do (if (equal item (aref gui-array r c))
+ (setf array-pos (list r c)))))
+ array-pos))
+
+(defun search-items-duplication (board-size gui-array label)
+ (let ((labels-list))
+ (loop for r from 0 below board-size
+ do (loop for c from 0 below board-size
+ do (if (equal label (label (aref gui-array r c)))
+ (setf labels-list (append labels-list
+ (list label r c))))))
+ labels-list))
+
+(defun check-in-same-block (r1 c1 r2 c2 board-size)
+ (let ((checking nil))
+ (loop for r-start-point from 0
+ below board-size by (ceiling (sqrt board-size))
+ do (loop for c-start-point from 0
+ below board-size by (ceiling (sqrt board-size))
+ do (let ((count 0))
+ (loop for r from r-start-point
+ below (+ r-start-point
+ (ceiling (sqrt board-size)))
+ do (loop for c from c-start-point
+ below (+ c-start-point
+ (ceiling (sqrt board-size)))
+ do (if (or (and (equal r r1)
+ (equal c c1))
+ (and (equal r r2)
+ (equal c c2)))
+ (incf count))))
+ (if (equal 2 count)
+ (setf checking t)))))
+ checking))
+
+(defun lets-search (labels-list gui-array)
+ (let ((list-length (length labels-list)))
+ (flet ((assign-dup-value (r-pos c-pos bool-value)
+ (setf (duplication (aref gui-array
+ r-pos
+ c-pos))
+ bool-value)))
+ (if (> list-length 3)
+ (progn (loop for i from 1 below list-length by 3
+ do (assign-dup-value (nth i labels-list)
+ (nth (1+ i) labels-list)
+ nil))
+ (loop for i from 1 below list-length by 3
+ do (loop for j from (+ i 3) below list-length by 3
+ do (if (or (equal (nth j labels-list)
+ (nth i labels-list))
+ (equal (nth (1+ j) labels-list)
+ (nth (1+ i) labels-list))
+ (equal (check-in-same-block
+ (nth j labels-list)
+ (nth (1+ j) labels-list)
+ (nth i labels-list)
+ (nth (1+ i) labels-list)
+ *board-size*)
+ t))
+ (progn (assign-dup-value
+ (nth j labels-list)
+ (nth (1+ j) labels-list)
+ t)
+ (assign-dup-value
+ (nth i labels-list)
+ (nth (1+ i) labels-list)
+ t))))))
+ (if (> list-length 0)
+ (assign-dup-value (nth 1 labels-list)
+ (nth 2 labels-list)
+ nil))))))
+
+(define-application-frame sudoku-gui ()
+ ((%cells :initform *gui-array*
+ :accessor cells)
+ (%symbols :initform *sudoku-symbol*
+ :accessor symbols))
+ (:menu-bar menubar-command-table)
+ (:panes (app :application-pane
+ :height 760 :width 760
+ :display-function 'display-app)
+ (int :interactor
+ :height 20 :width 760))
+ (:layouts (default (vertically () app int))))
+
+(defun draw-lines (pane
+ board-size cell-width
+ thin-line-width thick-line-width
+ initial-x initial-y)
+ (flet ((plus-plus-minus (initial line-width time)
+ (+ (+ (- initial line-width)
+ (* (+ cell-width thin-line-width) time))
+ (* (floor (/ time (sqrt board-size)))
+ (- thick-line-width thin-line-width))))
+ (plus-plus-board-size (initial)
+ (+ (+ initial (* (+ cell-width thin-line-width) board-size))
+ (* (/ board-size (sqrt board-size))
+ (- thick-line-width thin-line-width))))
+ (plus-plus-time (initial time)
+ (+ (+ initial (* (+ cell-width thin-line-width) time))
+ (* (floor (/ time (sqrt board-size)))
+ (- thick-line-width thin-line-width)))))
+ (flet ((draw-horizontal-line (type-of-line time)
+ (clim:draw-rectangle* pane
+ (- initial-x thick-line-width)
+ (plus-plus-minus initial-y type-of-line time)
+ (plus-plus-board-size initial-x)
+ (plus-plus-time initial-y time)))
+ (draw-vertical-line (type-of-line time)
+ (clim:draw-rectangle* pane
+ (plus-plus-minus initial-x type-of-line time)
+ initial-y
+ (plus-plus-time initial-x time)
+ (plus-plus-board-size initial-y))))
+ (loop for time from 0 to board-size
+ do (if (zerop (mod time (sqrt board-size)))
+ (progn (draw-horizontal-line thick-line-width time)
+ (draw-vertical-line thick-line-width time))
+ (progn (draw-horizontal-line thin-line-width time)
+ (draw-vertical-line thin-line-width time)))))))
+
+(defun display-app (frame pane)
+ (declare (ignore frame))
+ (let ((x *initial-x*) (y *initial-y*) (count-x 0) (count-y 0))
+ (loop for row from 0 below *board-size*
+ do (loop for column from 0 below *board-size*
+ do (let ((obj (aref *gui-array* row column)))
+ (with-output-as-presentation (pane obj (class-of obj))
+ (draw-rectangle* pane x y
+ (+ x *cell-width*) (+ y *cell-width*)
+ :ink (if (typep obj 'fixed-cell)
+ +green+
+ +orange+))))
+ do (let ((obj (aref *gui-array* row column)))
+ (draw-text* pane (label (aref *gui-array* row column))
+ (+ x (/ *cell-width* 2)) (+ y (/ *cell-width* 2))
+ :align-x :center :align-y :center
+ :ink (if (equal (duplication obj) t)
+ +red+
+ +black+)))
+ do (incf count-x)
+ do (if (= count-x (sqrt *board-size*))
+ (progn (incf x (+ *cell-width* *thick-line-width*))
+ (setf count-x 0))
+ (incf x (+ *cell-width* *thin-line-width*))))
+ do (incf count-y)
+ do (setf x *initial-x*)
+ do (if (= count-y (sqrt *board-size*))
+ (progn (incf y (+ *cell-width* *thick-line-width*))
+ (setf count-y 0))
+ (incf y (+ *cell-width* *thin-line-width*)))))
+ (draw-lines pane
+ *board-size* *cell-width*
+ *thin-line-width* *thick-line-width*
+ *initial-x* *initial-y*)
+ (let ((symbol-x (+ *initial-x* (/ *cell-width* 2))))
+ (loop for i from 0 below *board-size*
+ do (let ((obj (aref *sudoku-symbol* i)))
+ (with-output-as-presentation (pane obj (class-of obj))
+ (draw-text* pane (label (aref *sudoku-symbol* i))
+ symbol-x 30)))
+ do (incf symbol-x *cell-width*))))
+
+(defun sudoku-gui ()
+ (run-frame-top-level (make-application-frame 'sudoku-gui)))
+
+(make-command-table 'file-command-table
+ :errorp nil
+ :menu '(("New game" :command new-game)
+ ("Save game" :command save-game)
+ ("Load game" :command load-game)))
+
+(make-command-table 'difficulties-command-table
+ :errorp nil
+ :menu '(("Easy" :command easy-mode)
+ ("Medium" :command medium-mode)
+ ("Hard" :command hard-mode)))
+(make-command-table 'board-size-command-table
+ :errorp nil
+ :menu '(("4x4" :command size-four)
+ ("9x9 (Default)" :command size-nine)
+ ("16x16" :command size-sixteen)))
+(make-command-table 'cell-size-command-table
+ :errorp nil
+ :menu '(("Standard (Default)" :command cell-standard)
+ ("Large" :command cell-large)))
+(make-command-table 'lines-size-command-table
+ :errorp nil
+ :menu '(("Standard (Default)" :command lines-standard)
+ ("Bolder" :command lines-bolder)))
+
+(make-command-table 'menubar-command-table
+ :errorp nil
+ :menu '(("File" :menu file-command-table)
+ ("Difficulties" :menu difficulties-command-table)
+ ("Board-sizes" :menu board-size-command-table)
+ ("Cell-sizes" :menu cell-size-command-table)
+ ("Line-sizes" :menu lines-size-command-table)
+ ("Quit" :command quit)))
+
+(defun combo-command-for-size (size)
+ (setf *board-size* size)
+ (setf *gui-array* (make-gui-array *board-size*))
+ (setf *sudoku-symbol* (make-sudoku-symbol-array *board-size*))
+ (setf *hole-to-be-changed* NIL))
+
+(define-sudoku-gui-command new-game ())
+
+(define-sudoku-gui-command save-game ())
+
+(define-sudoku-gui-command load-game ())
+
+(define-sudoku-gui-command easy-mode ())
+
+(define-sudoku-gui-command medium-mode ())
+
+(define-sudoku-gui-command hard-mode ())
+
+(define-sudoku-gui-command size-four ()
+ (combo-command-for-size 4))
+
+(define-sudoku-gui-command size-nine ()
+ (combo-command-for-size 9))
+
+(define-sudoku-gui-command size-sixteen ()
+ (combo-command-for-size 16))
+
+(define-sudoku-gui-command cell-standard ()
+ (setf *cell-width* 35))
+
+(define-sudoku-gui-command cell-large ()
+ (setf *cell-width* 42))
+
+(define-sudoku-gui-command lines-standard ()
+ (setf *thin-line-width* 2)
+ (setf *thick-line-width* 4))
+
+(define-sudoku-gui-command lines-bolder ()
+ (setf *thin-line-width* 3)
+ (setf *thick-line-width* 5))
+
+(define-sudoku-gui-command quit ()
+ (clim:frame-exit clim:*application-frame*))
+
+(define-sudoku-gui-command (com-sudoku-symbol :name t)
+ ((sudoku-symbol 'sudoku-symbol))
+ (if (equal NIL *hole-to-be-changed*)
+ (format (find-pane-named *application-frame* 'int)
+ "Please select a hole to input first")
+ (progn (setf (label (aref *gui-array* (first *hole-to-be-changed*)
+ (second *hole-to-be-changed*)))
+ (label sudoku-symbol))
+ (setf *hole-to-be-changed* NIL)))
+ (loop for k from 1 to *board-size*
+ do (setf *labels-list* (search-items-duplication
+ *board-size*
+ *gui-array*
+ (format nil "~a" k)))
+ do (lets-search *labels-list* *gui-array*)))
+
+(define-presentation-to-command-translator com-sudoku-symbol-translator
+ (sudoku-symbol com-sudoku-symbol sudoku-gui)
+ (object)
+ (list object))
+
+(define-sudoku-gui-command (com-sudoku-hole :name t)
+ ((hole 'hole))
+ (let ((hole-position (search-pos *board-size* *gui-array* hole)))
+ (setf *hole-to-be-changed* hole-position)))
+
+(define-presentation-to-command-translator com-sudoku-hole-translator
+ (hole com-sudoku-hole sudoku-gui)
+ (object)
+ (list object))
+
+(define-sudoku-gui-command (com-sudoku-hole-error :name t)
+ ((hole-error 'hole-error))
+ (let ((hole-position (search-pos *board-size* *gui-array* hole-error)))
+ (setf *hole-to-be-changed* hole-position)))
+
+(define-presentation-to-command-translator com-sudoku-hole-error-translator
+ (hole-error com-sudoku-hole sudoku-gui)
+ (object)
+ (list object))
--- /dev/null
+(defsystem :sudoku
+ :depends-on (:mcclim)
+ :components
+ ((:file "packages")
+ (:file "sudoku-gui")
+ (:file "sudoku-algorithm")))
common-lisp.net / projects/sudoku/sudoku.git / commitdiff
