unofficial mirror of emacs-devel@gnu.org 
 help / color / mirror / code / Atom feed
blob e13a3c9a252f5c1d3fd79ef2985dc0e0e8058225 30620 bytes (raw)
name: lisp/play/5x5.el 	 # note: path name is non-authoritative(*)

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
 
;;; 5x5.el --- simple little puzzle game

;; Copyright (C) 1999-2019 Free Software Foundation, Inc.

;; Author: Dave Pearson <davep@davep.org>
;; Maintainer: Dave Pearson <davep@davep.org>
;; Created: 1998-10-03
;; Keywords: games puzzles

;; This file is part of GNU Emacs.

;; GNU Emacs is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; The aim of 5x5 is to fill in all the squares.  If you need any more of an
;; explanation you probably shouldn't play the game.

;;; TODO:

;; o The code for updating the grid needs to be re-done.  At the moment it
;;   simply re-draws the grid every time a move is made.
;;
;; o Look into tarting up the display with color.  gamegrid.el looks
;;   interesting, perhaps that is the way to go?

;;; Thanks:

;; Ralf Fassel <ralf@akutech.de> for his help and introduction to writing an
;; emacs mode.
;;
;; Pascal Q. Porcupine <joshagam@cs.nmsu.edu> for inspiring the animated
;; cracker.
;;
;; Vincent Belaïche <vincentb1@users.sourceforge.net> & Jay P. Belanger
;; <jay.p.belanger@gmail.com> for the math solver.

;;; Code:

;; Things we need.

(eval-when-compile (require 'cl-lib))

;; Customize options.

(defgroup 5x5 nil
  "5x5 - Silly little puzzle game."
  :group  'games
  :prefix "5x5-")

(defcustom 5x5-grid-size 5
  "Size of the playing area."
  :type  'integer
  :group '5x5)

(defcustom 5x5-x-scale 4
  "X scaling factor for drawing the grid."
  :type  'integer
  :group '5x5)

(defcustom 5x5-y-scale 3
  "Y scaling factor for drawing the grid."
  :type  'integer
  :group '5x5)

(defcustom 5x5-animate-delay .01
  "Delay in seconds when animating a solution crack."
  :type  'number
  :group '5x5)

(defcustom 5x5-hassle-me t
  "Should 5x5 ask you when you want to do a destructive operation?"
  :type  'boolean
  :group '5x5)

(defcustom 5x5-mode-hook nil
  "Hook run on starting 5x5."
  :type  'hook
  :group '5x5)

;; Non-customize variables.

(defmacro 5x5-defvar-local (var value doc)
  "Define VAR to VALUE with documentation DOC and make it buffer local."
  `(progn
     (defvar ,var ,value ,doc)
     (make-variable-buffer-local (quote ,var))))

(5x5-defvar-local 5x5-grid nil
  "5x5 grid contents.")

(5x5-defvar-local 5x5-x-pos 2
  "X position of cursor.")

(5x5-defvar-local 5x5-y-pos 2
  "Y position of cursor.")

(5x5-defvar-local 5x5-moves 0
  "Moves made.")

(5x5-defvar-local 5x5-cracking nil
  "Are we in cracking mode?")

(defvar 5x5-buffer-name "*5x5*"
  "Name of the 5x5 play buffer.")

(defvar 5x5-mode-map
  (let ((map (make-sparse-keymap)))
    (suppress-keymap map t)
    (define-key map "?"                       #'describe-mode)
    (define-key map "\r"                      #'5x5-flip-current)
    (define-key map " "                       #'5x5-flip-current)
    (define-key map [up]                      #'5x5-up)
    (define-key map [down]                    #'5x5-down)
    (define-key map [left]                    #'5x5-left)
    (define-key map [tab]                     #'5x5-right)
    (define-key map [right]                   #'5x5-right)
    (define-key map [(control a)]             #'5x5-bol)
    (define-key map [(control e)]             #'5x5-eol)
    (define-key map [(control p)]             #'5x5-up)
    (define-key map [(control n)]             #'5x5-down)
    (define-key map [(control b)]             #'5x5-left)
    (define-key map [(control f)]             #'5x5-right)
    (define-key map [home]                    #'5x5-bol)
    (define-key map [end]                     #'5x5-eol)
    (define-key map [prior]                   #'5x5-first)
    (define-key map [next]                    #'5x5-last)
    (define-key map "r"                       #'5x5-randomize)
    (define-key map [(control c) (control r)] #'5x5-crack-randomly)
    (define-key map [(control c) (control c)] #'5x5-crack-mutating-current)
    (define-key map [(control c) (control b)] #'5x5-crack-mutating-best)
    (define-key map [(control c) (control x)] #'5x5-crack-xor-mutate)
    (define-key map "n"                       #'5x5-new-game)
    (define-key map "s"                       #'5x5-solve-suggest)
    (define-key map "<"                       #'5x5-solve-rotate-left)
    (define-key map ">"                       #'5x5-solve-rotate-right)
    (define-key map "q"                       #'5x5-quit-game)
    map)
  "Local keymap for the 5x5 game.")

(5x5-defvar-local 5x5-solver-output nil
  "List that is the output of an arithmetic solver.

This list L is such that

L = (M S_1 S_2 ... S_N)

M is the move count when the solve output was stored.

S_1 ... S_N are all the solutions ordered from least to greatest
number of strokes.  S_1 is the solution to be displayed.

Each solution S_1, ..., S_N is a list (STROKE-COUNT GRID) where
STROKE-COUNT is the number of strokes to achieve the solution and
GRID is the grid of positions to click.")


;; Menu definition.

(easy-menu-define 5x5-mode-menu 5x5-mode-map "5x5 menu."
  '("5x5"
    ["New game"               5x5-new-game  t]
    ["Random game"            5x5-randomize t]
    ["Quit game"              5x5-quit-game t]
    "---"
    ["Use Calc solver"        5x5-solve-suggest         t]
    ["Rotate left list of Calc solutions"        5x5-solve-rotate-left     t]
    ["Rotate right list of Calc solutions"       5x5-solve-rotate-right    t]
    "---"
    ["Crack randomly"         5x5-crack-randomly         t]
    ["Crack mutating current" 5x5-crack-mutating-current t]
    ["Crack mutating best"    5x5-crack-mutating-best    t]
    ["Crack with xor mutate"  5x5-crack-xor-mutate       t]))

;; Gameplay functions.

(define-derived-mode 5x5-mode special-mode "5x5"
  "A mode for playing `5x5'."
  (setq buffer-read-only t
        truncate-lines   t)
  (buffer-disable-undo))

;;;###autoload
(defun 5x5 (&optional size)
  "Play 5x5.

The object of 5x5 is very simple, by moving around the grid and flipping
squares you must fill the grid.

5x5 keyboard bindings are:
\\<5x5-mode-map>
Flip                        \\[5x5-flip-current]
Move up                     \\[5x5-up]
Move down                   \\[5x5-down]
Move left                   \\[5x5-left]
Move right                  \\[5x5-right]
Start new game              \\[5x5-new-game]
New game with random grid   \\[5x5-randomize]
Random cracker              \\[5x5-crack-randomly]
Mutate current cracker      \\[5x5-crack-mutating-current]
Mutate best cracker         \\[5x5-crack-mutating-best]
Mutate xor cracker          \\[5x5-crack-xor-mutate]
Solve with Calc             \\[5x5-solve-suggest]
Rotate left Calc Solutions  \\[5x5-solve-rotate-left]
Rotate right Calc Solutions \\[5x5-solve-rotate-right]
Quit current game           \\[5x5-quit-game]"

  (interactive "P")
  (setq 5x5-cracking nil)
  (switch-to-buffer 5x5-buffer-name)
  (5x5-mode)
  (when (natnump size)
      (setq 5x5-grid-size size))
  (if (or (not 5x5-grid) (not (= 5x5-grid-size (length (aref 5x5-grid 0)))))
      (5x5-new-game))
  (5x5-draw-grid (list 5x5-grid))
  (5x5-position-cursor))

(defun 5x5-new-game ()
  "Start a new game of `5x5'."
  (interactive)
  (when (if (called-interactively-p 'interactive)
	    (5x5-y-or-n-p "Start a new game? ") t)
    (setq 5x5-x-pos (/ 5x5-grid-size 2)
          5x5-y-pos (/ 5x5-grid-size 2)
          5x5-moves 0
          5x5-grid  (5x5-make-move (5x5-make-new-grid) 5x5-y-pos 5x5-x-pos)
	  5x5-solver-output nil)
    (5x5-draw-grid (list 5x5-grid))
    (5x5-position-cursor)))

(defun 5x5-quit-game ()
  "Quit the current game of `5x5'."
  (interactive)
  (kill-buffer 5x5-buffer-name))

(defun 5x5-make-new-grid ()
  "Create and return a new `5x5' grid structure."
  (let ((grid (make-vector 5x5-grid-size nil)))
    (dotimes (y 5x5-grid-size)
      (aset grid y (make-vector 5x5-grid-size nil)))
    grid))

(defun 5x5-cell (grid y x)
  "Return the value of the cell in GRID at location X,Y."
  (aref (aref grid y) x))

(defun 5x5-set-cell (grid y x value)
  "Set the value of cell X,Y in GRID to VALUE."
  (aset (aref grid y) x value))

(defun 5x5-flip-cell (grid y x)
  "Flip the value of cell X,Y in GRID."
  (5x5-set-cell grid y x (not (5x5-cell grid y x))))

(defun 5x5-copy-grid (grid)
  "Make a new copy of GRID."
  (let ((copy (5x5-make-new-grid)))
    (dotimes (y 5x5-grid-size)
      (dotimes (x 5x5-grid-size)
        (5x5-set-cell copy y x (5x5-cell grid y x))))
    copy))

(defun 5x5-make-move (grid row col)
  "Make a move on GRID at row ROW and column COL."
  (5x5-flip-cell grid row col)
  (if (> row 0)
      (5x5-flip-cell grid (1- row) col))
  (if (< row (- 5x5-grid-size 1))
      (5x5-flip-cell grid (1+ row) col))
  (if (> col 0)
      (5x5-flip-cell grid row (1- col)))
  (if (< col (- 5x5-grid-size 1))
      (5x5-flip-cell grid row (1+ col)))
  grid)

(defun 5x5-row-value (row)
  "Get the \"on-value\" for grid row ROW."
  (cl-loop for y from 0 to (1- 5x5-grid-size) sum (if (aref row y) 1 0)))

(defun 5x5-grid-value (grid)
  "Get the \"on-value\" for grid GRID."
  (cl-loop for y from 0 to (1- 5x5-grid-size)
           sum (5x5-row-value (aref grid y))))

(defun 5x5-draw-grid-end ()
  "Draw the top/bottom of the grid."
  (insert "+")
  (dotimes (x 5x5-grid-size)
    (insert "-" (make-string 5x5-x-scale ?-)))
  (insert "-+ "))

(defun 5x5-draw-grid (grids)
  "Draw the grids GRIDS into the current buffer."
  (let ((inhibit-read-only t) grid-org)
    (erase-buffer)
    (dolist (grid grids) (5x5-draw-grid-end))
    (insert "\n")
    (setq grid-org (point))
    (dotimes (y 5x5-grid-size)
      (dotimes (lines 5x5-y-scale)
        (dolist (grid grids)
          (dotimes (x 5x5-grid-size)
            (insert (if (zerop x) "| " " ")
                    (make-string 5x5-x-scale
                                 (if (5x5-cell grid y x) ?# ?.))))
          (insert " | "))
        (insert "\n")))
    (when 5x5-solver-output
      (if (= (car 5x5-solver-output) 5x5-moves)
	  (save-excursion
	    (goto-char grid-org)
	    (beginning-of-line (+ 1 (/ 5x5-y-scale 2)))
	    (let ((solution-grid (cl-cdadr 5x5-solver-output)))
	      (dotimes (y 5x5-grid-size)
		(save-excursion
		  (forward-char  (+ 1 (/ (1+ 5x5-x-scale) 2)))
		  (dotimes (x 5x5-grid-size)
		    (when (5x5-cell solution-grid y x)
		      (if (= 0 (mod 5x5-x-scale 2))
			  (progn
			    (insert "()")
			    (delete-region (point) (+ (point) 2))
			    (backward-char 2))
			(insert-char ?O 1)
			(delete-char 1)
			(backward-char)))
		    (forward-char  (1+ 5x5-x-scale))))
		(forward-line  5x5-y-scale))))
	(setq 5x5-solver-output nil)))
    (dolist (grid grids) (5x5-draw-grid-end))
    (insert "\n")
    (insert (format "On: %d  Moves: %d" (5x5-grid-value (car grids)) 5x5-moves))))

(defun 5x5-position-cursor ()
  "Position the cursor on the grid."
  (goto-char (point-min))
  (forward-line (1+ (* 5x5-y-pos 5x5-y-scale)))
  (goto-char (+ (point) (* 5x5-x-pos 5x5-x-scale) (+ 5x5-x-pos 1) 1)))

(defun 5x5-made-move ()
  "Keep track of how many moves have been made."
  (cl-incf 5x5-moves))

(defun 5x5-make-random-grid (&optional move)
  "Make a random grid."
  (setq move (or move (symbol-function '5x5-flip-cell)))
  (let ((grid (5x5-make-new-grid)))
    (dotimes (y 5x5-grid-size)
      (dotimes (x 5x5-grid-size)
        (if (zerop (random 2))
            (funcall move grid y x))))
    grid))

;; Cracker functions.

;;;###autoload
(defun 5x5-crack-randomly ()
  "Attempt to crack 5x5 using random solutions."
  (interactive)
  (5x5-crack #'5x5-make-random-solution))

;;;###autoload
(defun 5x5-crack-mutating-current ()
  "Attempt to crack 5x5 by mutating the current solution."
  (interactive)
  (5x5-crack #'5x5-make-mutate-current))

;;;###autoload
(defun 5x5-crack-mutating-best ()
  "Attempt to crack 5x5 by mutating the best solution."
  (interactive)
  (5x5-crack #'5x5-make-mutate-best))

;;;###autoload
(defun 5x5-crack-xor-mutate ()
  "Attempt to crack 5x5 by xoring the current and best solution.
Mutate the result."
  (interactive)
  (5x5-crack #'5x5-make-xor-with-mutation))

;;;###autoload
(defun 5x5-crack (breeder)
  "Attempt to find a solution for 5x5.

5x5-crack takes the argument BREEDER which should be a function that takes
two parameters, the first will be a grid vector array that is the current
solution and the second will be the best solution so far.  The function
should return a grid vector array that is the new solution."

  (interactive "aBreeder function: ")
  (5x5)
  (setq 5x5-cracking t)
  (let* ((best-solution    (5x5-make-random-grid))
         (current-solution best-solution)
         (best-result      (5x5-make-new-grid))
         (current-result   (5x5-make-new-grid))
         (target           (* 5x5-grid-size 5x5-grid-size)))
    (while (and (< (5x5-grid-value best-result) target)
                (not (input-pending-p)))
      (setq current-result (5x5-play-solution current-solution best-solution))
      (if (> (5x5-grid-value current-result) (5x5-grid-value best-result))
          (setq best-solution current-solution
                best-result   current-result))
      (setq current-solution (funcall breeder
                                      (5x5-copy-grid current-solution)
                                      (5x5-copy-grid best-solution)))))
  (setq 5x5-cracking nil))

(defun 5x5-make-random-solution (&rest _ignore)
  "Make a random solution."
  (5x5-make-random-grid))

(defun 5x5-make-mutate-current (current _best)
  "Mutate the current solution."
  (5x5-mutate-solution current))

(defun 5x5-make-mutate-best (_current best)
  "Mutate the best solution."
  (5x5-mutate-solution best))

(defun 5x5-make-xor-with-mutation (current best)
  "Xor current and best solution then mutate the result."
  (let ((xored (5x5-make-new-grid)))
    (dotimes (y 5x5-grid-size)
      (dotimes (x 5x5-grid-size)
        (5x5-set-cell xored y x
                      (5x5-xor (5x5-cell current y x)
                               (5x5-cell best    y x)))))
    (5x5-mutate-solution xored)))

(defun 5x5-mutate-solution (solution)
  "Randomly flip bits in the solution."
  (dotimes (y 5x5-grid-size)
    (dotimes (x 5x5-grid-size)
      (if (= (random (/ (* 5x5-grid-size 5x5-grid-size) 2))
             (/ (/ (* 5x5-grid-size 5x5-grid-size) 2) 2))
          (5x5-flip-cell solution y x))))
  solution)

(defun 5x5-play-solution (solution best)
  "Play a solution on an empty grid.  This destroys the current game
in progress because it is an animated attempt."
  (5x5-new-game)
  (let ((inhibit-quit t))
    (dotimes (y 5x5-grid-size)
      (dotimes (x 5x5-grid-size)
        (setq 5x5-y-pos y
              5x5-x-pos x)
        (if (5x5-cell solution y x)
            (5x5-flip-current))
        (5x5-draw-grid (list 5x5-grid solution best))
        (5x5-position-cursor)
        (sit-for 5x5-animate-delay))))
  5x5-grid)

;; Arithmetic solver
;;===========================================================================
(defun 5x5-grid-to-vec (grid)
  "Convert GRID to an equivalent Calc matrix of (mod X 2) forms
where X is 1 for setting a position, and 0 for unsetting a
position."
  (cons 'vec
	(mapcar (lambda (y)
		  (cons 'vec
			(mapcar (lambda (x)
				  (if x '(mod 1 2) '(mod 0 2)))
				y)))
		grid)))

(defun 5x5-vec-to-grid (grid-matrix)
  "Convert a grid matrix GRID-MATRIX in Calc format to a grid in
5x5 format.  See function `5x5-grid-to-vec'."
  (apply
   'vector
   (mapcar
    (lambda (x)
      (apply
       'vector
       (mapcar
	(lambda (y) (/= (cadr y) 0))
	(cdr x))))
    (cdr grid-matrix))))

(eval-and-compile
(if nil; set to t to enable solver logging
    ;; Note these logging facilities were not cleaned out as the arithmetic
    ;; solver is not yet complete --- it works only for grid size = 5.
    ;; So they may be useful again to design a more generic solution.
    (progn
      (defvar 5x5-log-buffer nil)
      (defun 5x5-log-init ()
	(if (buffer-live-p 5x5-log-buffer)
	    (with-current-buffer 5x5-log-buffer (erase-buffer))
	  (setq 5x5-log-buffer (get-buffer-create "*5x5 LOG*"))))

      (defun 5x5-log (name value)
	"Debug purposes only.

Log a matrix VALUE of (mod B 2) forms, only B is output and
Scilab matrix notation is used.  VALUE is returned so that it is
easy to log a value with minimal rewrite of code."
	(when (buffer-live-p 5x5-log-buffer)
	  (let* ((unpacked-value
		  (math-map-vec
		   (lambda (row) (math-map-vec 'cadr row))
		   value))
		 (calc-vector-commas "")
		 (calc-matrix-brackets '(C O))
		 (value-to-log (math-format-value unpacked-value)))
	    (with-current-buffer 5x5-log-buffer
	      (insert name ?= value-to-log ?\n))))
	value))
  (defsubst 5x5-log-init ())
  (defsubst 5x5-log (name value) value)))

(declare-function math-map-vec "calc-vec" (f a))
(declare-function math-sub "calc" (a b))
(declare-function math-mul "calc" (a b))
(declare-function math-make-intv "calc-forms" (mask lo hi))
(declare-function math-reduce-vec "calc-vec" (a b))
(declare-function math-format-number "calc" (a &optional prec))
(declare-function math-pow "calc-misc" (a b))
(declare-function calcFunc-arrange "calc-vec" (vec cols))
(declare-function calcFunc-cvec "calc-vec" (obj &rest dims))
(declare-function calcFunc-diag "calc-vec" (a &optional n))
(declare-function calcFunc-trn "calc-vec" (mat))
(declare-function calcFunc-inv "calc-misc" (m))
(declare-function calcFunc-mrow "calc-vec" (mat n))
(declare-function calcFunc-mcol "calc-vec" (mat n))
(declare-function calcFunc-vconcat "calc-vec" (a b))
(declare-function calcFunc-index "calc-vec" (n &optional start incr))

(defun 5x5-solver (grid)
  "Return a list of solutions for GRID.

Given some grid GRID, the returned a list of solution LIST is
sorted from least Hamming weight to greatest one.

   LIST = (SOLUTION-1 ... SOLUTION-N)

Each solution SOLUTION-I is a cons cell (HW . G) where HW is the
Hamming weight of the solution --- ie the number of strokes to
achieve it --- and G is the grid of positions to click in order
to complete the 5x5.

Solutions are sorted from least to greatest Hamming weight."
  (require 'calc-ext)
  (cl-flet ((5x5-mat-mode-2
             (a)
             (math-map-vec
              (lambda (y)
                (math-map-vec
                 (lambda (x) `(mod ,x 2))
                 y))
              a)))
    (let* (calc-command-flags
	   (grid-size-squared (* 5x5-grid-size 5x5-grid-size))

	   ;; targetv is the vector the origin of which is org="current
	   ;; grid" and the end of which is dest="all ones".
	   (targetv
	    (5x5-log
	     "b"
	     (let (
		   ;; org point is the current grid
		   (org (calcFunc-arrange (5x5-grid-to-vec grid)
					  1))

		   ;; end point of game is the all ones matrix
		   (dest (calcFunc-cvec '(mod 1 2) grid-size-squared 1)))
	       (math-sub dest org))))

	   ;; transferm is the transfer matrix, ie it is the 25x25
	   ;; matrix applied everytime a flip is carried out where a
	   ;; flip is defined by a 25x1 Dirac vector --- ie all zeros
	   ;; but 1 in the position that is flipped.
	   (transferm
	    (5x5-log
	     "a"
	     ;; transfer-grid is not a play grid, but this is the
	     ;; transfer matrix in the format of a vector of vectors, we
	     ;; do it this way because random access in vectors is
	     ;; faster.  The motivation is just speed as we build it
	     ;; element by element, but that could have been created
	     ;; using only Calc primitives.  Probably that would be a
	     ;; better idea to use Calc with some vector manipulation
	     ;; rather than going this way...
	     (5x5-grid-to-vec (let ((transfer-grid
				     (let ((5x5-grid-size grid-size-squared))
				       (5x5-make-new-grid))))
				(dotimes (i 5x5-grid-size)
				  (dotimes (j 5x5-grid-size)
				    ;; k0 = flattened flip position corresponding
				    ;;      to (i, j) on the grid.
				    (let* ((k0 (+ (* 5 i) j)))
				      ;; cross center
				      (5x5-set-cell transfer-grid k0 k0 t)
				      ;; Cross top.
				      (and
				       (> i 0)
				       (5x5-set-cell transfer-grid
						     (- k0 5x5-grid-size) k0 t))
				      ;; Cross bottom.
				      (and
				       (< (1+ i) 5x5-grid-size)
				       (5x5-set-cell transfer-grid
						     (+ k0 5x5-grid-size) k0 t))
				      ;; Cross left.
				      (and
				       (> j 0)
				       (5x5-set-cell transfer-grid (1- k0) k0 t))
				      ;; Cross right.
				      (and
				       (< (1+ j)  5x5-grid-size)
				       (5x5-set-cell transfer-grid
						     (1+ k0) k0 t)))))
				transfer-grid))))
	   ;; TODO: this is hard-coded for grid-size = 5, make it generic.
	   (transferm-kernel-size
	    (if (= 5x5-grid-size 5) 2
	      (error "Transfer matrix rank not known for grid-size != 5")))

	   ;; TODO: this is hard-coded for grid-size = 5, make it generic.
	   ;;
	   ;; base-change is a 25x25 matrix, where topleft submatrix
	   ;; 23x25 is a diagonal of 1, and the two last columns are a
	   ;; base of kernel of transferm.
	   ;;
	   ;; base-change must be by construction invertible.
	   (base-change
	    (5x5-log
	     "p"
	     (let ((id (5x5-mat-mode-2 (calcFunc-diag 1 grid-size-squared))))
	       (setcdr (last id (1+ transferm-kernel-size))
		       (cdr (5x5-mat-mode-2
			     '(vec (vec 0 1 1 1 0 1 0 1 0 1 1 1 0 1
					1 1 0 1 0 1 0 1 1 1 0)
                               (vec 1 1 0 1 1 0 0 0 0 0 1 1 0 1
                                    1 0 0 0 0 0 1 1 0 1 1)))))
	       (calcFunc-trn id))))

	   (inv-base-change
	    (5x5-log "invp"
		     (calcFunc-inv base-change)))

	   ;; B:= targetv
	   ;; A:= transferm
	   ;; P:= base-change
	   ;; P^-1 := inv-base-change
	   ;; X := solution

	   ;; B = A * X
	   ;; P^-1 * B = P^-1 * A * P * P^-1 * X
	   ;; CX = P^-1 * X
	   ;; CA = P^-1 * A * P
	   ;; CB = P^-1 * B
	   ;; CB = CA * CX
	   ;; CX = CA^-1 * CB
	   ;; X = P * CX
	   (ctransferm
	    (5x5-log
	     "ca"
	     (math-mul
	      inv-base-change
	      (math-mul transferm base-change)))); CA
	   (ctarget
	    (5x5-log
	     "cb"
	     (math-mul inv-base-change targetv))); CB
	   (row-1  (math-make-intv 3  1 transferm-kernel-size)) ; 1..2
	   (row-2   (math-make-intv 1 transferm-kernel-size
				    grid-size-squared)); 3..25
	   (col-1 (math-make-intv 3 1  (- grid-size-squared
					  transferm-kernel-size))); 1..23
	   (col-2 (math-make-intv 1 (- grid-size-squared
				       transferm-kernel-size)
				  grid-size-squared)); 24..25
	   (ctransferm-1-: (calcFunc-mrow ctransferm row-1))
	   (ctransferm-1-1 (calcFunc-mcol ctransferm-1-: col-1))

	   ;; By construction ctransferm-:-2 = 0, so ctransferm-1-2 = 0
	   ;; and ctransferm-2-2 = 0.

	   ;;(ctransferm-1-2 (calcFunc-mcol ctransferm-1-: col-2))
	   (ctransferm-2-: (calcFunc-mrow ctransferm row-2))
	   (ctransferm-2-1
	    (5x5-log
	     "ca_2_1"
	     (calcFunc-mcol ctransferm-2-: col-1)))

	   ;; By construction ctransferm-2-2 = 0.
	   ;;
	   ;;(ctransferm-2-2 (calcFunc-mcol ctransferm-2-: col-2))

	   (ctarget-1 (calcFunc-mrow ctarget row-1))
	   (ctarget-2 (calcFunc-mrow ctarget row-2))

	   ;;   ctarget-1(2x1)  =   ctransferm-1-1(2x23) *cx-1(23x1)
	   ;;                     + ctransferm-1-2(2x2) *cx-2(2x1);
	   ;;   ctarget-2(23x1) =   ctransferm-2-1(23x23)*cx-1(23x1)
	   ;;                     + ctransferm-2-2(23x2)*cx-2(2x1);
	   ;;   By construction:
	   ;;
	   ;;   ctransferm-1-2 == zeros(2,2) and ctransferm-2-2 == zeros(23,2)
	   ;;
	   ;;   So:
	   ;;
	   ;;   ctarget-2 = ctransferm-2-1*cx-1
	   ;;
	   ;;   So:
	   ;;
	   ;;   cx-1 = inv-ctransferm-2-1 * ctarget-2
	   (cx-1 (math-mul (calcFunc-inv ctransferm-2-1) ctarget-2))

	   ;; Any cx-2 can do, so there are 2^{transferm-kernel-size} solutions.
	   (solution-list
	    ;; Within solution-list each element is a cons cell:
	    ;;
	    ;; (HW . SOL)
	    ;;
	    ;; where HW is the Hamming weight of solution, and SOL is
	    ;; the solution in the form of a grid.
	    (sort
	     (cdr
	      (math-map-vec
	       (lambda (cx-2)
		 ;; Compute `solution' in the form of a 25x1 matrix of
		 ;; (mod B 2) forms --- with B = 0 or 1 --- and
		 ;; return (HW . SOL) where HW is the Hamming weight
		 ;; of solution and SOL a grid.
		 (let ((solution (math-mul
				  base-change
				  (calcFunc-vconcat cx-1 cx-2)))); X = P * CX
		   (cons
		    ;; The Hamming Weight is computed by matrix reduction
		    ;; with an ad-hoc operator.
		    (math-reduce-vec
		     ;; (cl-cadadr '(vec (mod x 2))) => x
		     (lambda (r x) (+ (if (integerp r) r (cl-cadadr r))
				      (cl-cadadr x)))
		     solution); car
		    (5x5-vec-to-grid
		     (calcFunc-arrange solution 5x5-grid-size));cdr
		    )))
	       ;; A (2^K) x K matrix, where K is the dimension of kernel
	       ;; of transfer matrix --- i.e. K=2 in if the grid is 5x5
	       ;; --- for I from 0 to K-1, each row rI correspond to the
	       ;; binary representation of number I, that is to say row
	       ;; rI is a 1xK vector:
	       ;;    [ n{I,0} n{I,1} ... n{I,K-1} ]
	       ;; such that:
	       ;;    I = sum for J=0..K-1 of 2^(n{I,J})
	       (let ((calc-number-radix 2)
		     (calc-leading-zeros t)
		     (calc-word-size transferm-kernel-size))
		 (math-map-vec
		  (lambda (x)
		    (cons 'vec
			  (mapcar (lambda (x) `(vec (mod ,(logand x 1) 2)))
				  (substring (math-format-number x)
					     (- transferm-kernel-size)))))
		  (calcFunc-index (math-pow 2 transferm-kernel-size) 0))) ))
	     ;; Sort solutions according to respective Hamming weight.
	     (lambda (x y) (< (car x) (car y)))
	     )))
      (message "5x5 Solution computation done.")
      solution-list)))

(defun 5x5-solve-suggest (&optional n)
  "Suggest to the user where to click.

Argument N is ignored."
  ;; For the time being n is ignored, the idea was to use some numeric
  ;; argument to show a limited amount of positions.
  (interactive "P")
  (5x5-log-init)
  (let ((solutions (5x5-solver 5x5-grid)))
    (setq 5x5-solver-output
	  (cons 5x5-moves solutions)))
  (5x5-draw-grid (list 5x5-grid))
  (5x5-position-cursor))

(defun 5x5-solve-rotate-left (&optional n)
  "Rotate left by N the list of solutions in 5x5-solver-output.

If N is not supplied rotate by 1, that is to say put the last
element first in the list.

The 5x5 game has in general several solutions.  For grid size=5,
there are 4 possible solutions.  When function
`5x5-solve-suggest' (press `\\[5x5-solve-suggest]') is called the
solution that is presented is the one that needs least number of
strokes --- other solutions can be viewed by rotating through the
list. The list of solution is ordered by number of strokes, so
rotating left just after calling `5x5-solve-suggest' will show
the solution with second least number of strokes, while rotating
right will show the solution with greatest number of strokes."
  (interactive "P")
  (let ((len  (length 5x5-solver-output)))
    (when (>= len 3)
      (setq n (if (integerp n) n 1)
	    n (mod n (1- len)))
      (unless (eq n 0)
	(setq n  (- len n 1))
	(let* ((p-tail (last 5x5-solver-output (1+ n)))
	       (tail (cdr p-tail))
	       (l-tail (last tail)))
	  ;;
	  ;;  For n = 2:
	  ;;
	  ;;  +--+--+   +--+--+   +--+--+   +--+--+   +--+--+
	  ;;  |M | ---->|S1| ---->|S2| ---->|S3| ---->|S4| ----> nil
	  ;;  +--+--+   +--+--+   +--+--+   +--+--+   +--+--+
	  ;;    ^ 		    ^         ^         ^
	  ;;    | 		    |         |         |
	  ;;    + 5x5-solver-output |         |         + l-tail
	  ;;			    + p-tail  |
	  ;;			              + tail
	  ;;
	  (setcdr l-tail (cdr 5x5-solver-output))
	  (setcdr 5x5-solver-output tail)
	  (unless (eq p-tail 5x5-solver-output)
	    (setcdr p-tail nil)))
	(5x5-draw-grid (list 5x5-grid))
	(5x5-position-cursor)))))

(defun 5x5-solve-rotate-right (&optional n)
  "Rotate right by N the list of solutions in 5x5-solver-output.
If N is not supplied, rotate by 1.  Similar to function
`5x5-solve-rotate-left' except that rotation is right instead of
lest."
  (interactive "P")
  (setq n
	(if (integerp n) (- n)
	  -1))
  (5x5-solve-rotate-left n))



;; Keyboard response functions.

(defun 5x5-flip-current ()
  "Make a move on the current cursor location."
  (interactive)
  (setq 5x5-grid (5x5-make-move 5x5-grid 5x5-y-pos 5x5-x-pos))
  (5x5-made-move)
  (unless 5x5-cracking
    (5x5-draw-grid (list 5x5-grid)))
  (5x5-position-cursor)
  (when (= (5x5-grid-value 5x5-grid) (* 5x5-grid-size 5x5-grid-size))
    (beep)
    (message "You win!")))

(defun 5x5-up ()
  "Move up."
  (interactive)
  (unless (zerop 5x5-y-pos)
    (cl-decf 5x5-y-pos)
    (5x5-position-cursor)))

(defun 5x5-down ()
  "Move down."
  (interactive)
  (unless (= 5x5-y-pos (1- 5x5-grid-size))
    (cl-incf 5x5-y-pos)
    (5x5-position-cursor)))

(defun 5x5-left ()
  "Move left."
  (interactive)
  (unless (zerop 5x5-x-pos)
    (cl-decf 5x5-x-pos)
    (5x5-position-cursor)))

(defun 5x5-right ()
  "Move right."
  (interactive)
  (unless (= 5x5-x-pos (1- 5x5-grid-size))
    (cl-incf 5x5-x-pos)
    (5x5-position-cursor)))

(defun 5x5-bol ()
  "Move to beginning of line."
  (interactive)
  (setq 5x5-x-pos 0)
  (5x5-position-cursor))

(defun 5x5-eol ()
  "Move to end of line."
  (interactive)
  (setq 5x5-x-pos (1- 5x5-grid-size))
  (5x5-position-cursor))

(defun 5x5-first ()
  "Move to the first cell."
  (interactive)
  (setq 5x5-x-pos 0
        5x5-y-pos 0)
  (5x5-position-cursor))

(defun 5x5-last ()
  "Move to the last cell."
  (interactive)
  (setq 5x5-x-pos (1- 5x5-grid-size)
        5x5-y-pos (1- 5x5-grid-size))
  (5x5-position-cursor))

(defun 5x5-randomize ()
  "Randomize the grid."
  (interactive)
  (when (5x5-y-or-n-p "Start a new game with a random grid? ")
    (setq 5x5-x-pos (/ 5x5-grid-size 2)
          5x5-y-pos (/ 5x5-grid-size 2)
          5x5-moves 0
          5x5-grid  (5x5-make-random-grid (symbol-function '5x5-make-move))
	  5x5-solver-output nil)
    (unless 5x5-cracking
      (5x5-draw-grid (list 5x5-grid)))
    (5x5-position-cursor)))

;; Support functions

(defun 5x5-xor (x y)
  "Boolean exclusive-or of X and Y."
  (and (or x y) (not (and x y))))

(defun 5x5-y-or-n-p (prompt)
  "5x5 wrapper for `y-or-n-p' which respects the `5x5-hassle-me' setting."
  (if 5x5-hassle-me
      (y-or-n-p prompt)
    t))

(provide '5x5)

;;; 5x5.el ends here

debug log:

solving e13a3c9a25 ...
found e13a3c9a25 in https://git.savannah.gnu.org/cgit/emacs.git

(*) Git path names are given by the tree(s) the blob belongs to.
    Blobs themselves have no identifier aside from the hash of its contents.^

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).