;;; Positions are (x . y) where the axes are (1 0) and (1/2 sqrt(3)/2)
;;; Board is a list of pieces, where a piece is a list
;;;   (pos color type height),
;;; color being black or white, and type is a member of '(tott tzarra tzaar).

;;; Moves are represented by (pos . dir) where 0 <= dir <= 5.

;;; Graphically, black/white is represented by blue/red,
;;; and the different types by ○ ◎ ●.

(cond-expand
  (guile
   (import (srfi srfi-1))
   (define (raw-terminal on)
     (if on
         (system "stty raw -echo")
         (system "stty cooked echo"))))
  (chicken
   (import (chicken random) (chicken sort) (srfi 1) shell)
   (define random pseudo-random-integer)
   (define (raw-terminal on)
     (if on
         (run (stty raw -echo))
         (run (stty cooked echo)))))
  (gambit ; run with -:tE [but input still not working properly]
   (import (srfi 1))
   (define random random-integer)
   (define (sort lst proc) (list-sort proc lst))
   (define (raw-terminal on)
     (if on
         (shell-command "stty raw -echo")
         (shell-command "stty cooked echo")))))

(define piece-position car)
(define piece-color cadr)
(define piece-type caddr)
(define piece-height cadddr)

(define change-position! set-car!)
(define (increase-height! piece delta)
  (set-car! (cdddr piece)
            (+ (piece-height piece) delta)))

(define (get-piece board pos) (assoc pos board))

(define (position-valid p)
  (let ((x (car p))
        (y (cdr p)))
    (and (<= -4 x 4)
         (<= -4 y 4)
         (not (= x y 0))
         (<= -4 (+ x y) 4))))

(define all-positions
  (filter position-valid
          (fold (lambda (x lst)
                  (append (map (lambda (y)
                                 (cons x y))
                               (iota 9 -4))
                          lst))
                '() (iota 9 -4))))

(define (shuffle lst)
  (let* ((v (list->vector lst))
         (n (vector-length v)))
    (do ((i 0 (+ i 1)))
        ((= i n) (vector->list v))
      (let* ((j (+ i (random (- n i))))
             (old (vector-ref v i)))
        (vector-set! v i (vector-ref v j))
        (vector-set! v j old)))))

(define (random-board)
  (let ((make-pieces (lambda (n color type)
                       (list-tabulate n (lambda (x) (list color type 1))))))
    (let ((pieces (append (make-pieces 15 'black 'tott)
                          (make-pieces 9 'black 'tzarra)
                          (make-pieces 6 'black 'tzaar)
                          (make-pieces 15 'white 'tott)
                          (make-pieces 9 'white 'tzarra)
                          (make-pieces 6 'white 'tzaar))))
      (map cons all-positions (shuffle pieces)))))

(define (direction n)
  (list-ref '((1 . 0) (0 . 1) (-1 . 1) (-1 . 0) (0 . -1) (1 . -1)) n))

(define (move pos dir)
  (cons (+ (car pos) (car dir))
        (+ (cdr pos) (cdr dir))))

(define (position-next board pos dir)
  (let ((next (move pos dir)))
    (if (position-valid next)
        (if (member next (map piece-position board))
            next
            (position-next board next dir))
        #f)))

(define (has-all-types? board color)
  (let ((types (map piece-type
                    (filter (lambda (x)
                              (eq? (piece-color x) color))
                            board))))
    (and (member 'tott types)
         (member 'tzarra types)
         (member 'tzaar types))))

(define (all-moves-from board pos attack?)
  (let* ((self (get-piece board pos))
         (color (piece-color self))
         (height (piece-height self)))
    (fold (lambda (n lst)
                  (let ((next (position-next board pos (direction n))))
                    (if (and next
                             (let ((piece (get-piece board next)))
                               (if (eq? color (piece-color piece))
                                   (not attack?)
                                   (>= height (piece-height piece)))))
                        (cons (cons pos n) lst)
                        lst)))
                '() '(0 1 2 3 4 5))))

(define (all-moves board color attack?)
  (fold (lambda (p lst)
          (if (eq? (piece-color p) color)
              (append (all-moves-from board (piece-position p) attack?) lst)
              lst))
        '() board))

;;; Here `move` is a pair of positions
(define (make-move board move)
  (let* ((from (car move))
         (to (cdr move))
         (old (get-piece board to))
         (w/o-to (remove (lambda (p)
                           (equal? (piece-position p) to))
                         board)))
    (begin
      (when (eq? (piece-color (get-piece board from))
                 (piece-color old))
        (increase-height! (get-piece w/o-to from)
                          (piece-height old)))
      (change-position! (get-piece w/o-to from) to)
      w/o-to)))

(define (add-empty board)
  (append (map (lambda (p)
                 (list p 'empty 'empty 1))
               (remove (lambda (p)
                         (get-piece board p))
                       all-positions))
          board))

;;; VT100 sequence for the given color/highlight
(define (set-style color hi)
  (display "[")
  (display (case color
             ((black) 36)
             ((white) 31)
             ((empty) 39)))
  (for-each (lambda (h)
              (display ";")
              (case h
                ((1) (display 1))
                ((2) (display 7))
                ((3) (display 4))
                ((4) (display 5))))
            hi)
  (display "m"))

;;; `highlights` is a list of pairs (pos . hi),
;;; where `hi` is a list of the highlight types:
;;; - 1 for last move (from-to), shown in bold,
;;; - 2 for selected position, shown inverted
;;; - 3 for possible positions/endpoints, shown with underline
;;; - 4 for selected endpoint, shown blinking
(define (draw-board board highlights)
  (for-each (lambda (p)
              (let* ((pos (piece-position p))
                     (hi (assoc pos highlights)))
                (set-style (piece-color p)
                           (if hi (cdr hi) '()))
                (display "[")
                (let ((x (+ 1 (* 2 (+ 8 (* 2 (car pos)) (cdr pos)))))
                      (y (+ 1 (* 2 (+ 4 (- (cdr pos)))))))
                  (display y)
                  (display ";")
                  (display x))
                (display "H")
                (display " ")
                (display (case (piece-type p)
                           ((tott) "○")
                           ((tzarra) "◎")
                           ((tzaar) "●")
                           ((empty) "-")))
                (if (> (piece-height p) 1)
                    (display (piece-height p))
                    (display " "))
                (display "")))
            board))

(define (other-color color)
  (if (eq? color 'black)
      'white
      'black))

(define (pos< p q)
  (or (> (cdr p) (cdr q))
      (and (= (cdr p) (cdr q))
           (< (car p) (car q)))))

(define (init-screen)
  (raw-terminal #t)
  (display "[?25l")
  (display "JK: change selection\n\r")
  (display "L: select\n\r")
  (display "H: back to piece selection\n\r")
  (display "P: pass (only possible for the 2nd part)\n\r")
  (display "Q: quit\n\r"))

(define (restore-screen)
  (display "[?25h")
  (raw-terminal #f))

(define (print-winner winner)
  (display "")
  (case winner
    ((white) (display "Red player won!\n\r"))
    ((black) (display "Blue player won!\n\r"))
    (else (display "Bye!\n\r"))))

;;; From
;;;  ((pos1 . h1) (pos2 . h2) (pos1 . h3) ...)
;;; makes
;;;  ((pos1 h1 h3) (pos2 h2) ...)
(define (contract-highlights hi)
  (if (null? hi)
      '()
      (let* ((pos (caar hi))
             (style (map cdr
                         (filter (lambda (h)
                                   (equal? (car h) pos))
                                 hi)))
             (rest (remove (lambda (h)
                             (equal? (car h) pos))
                           hi)))
        (cons (cons pos style)
              (contract-highlights rest)))))

(define (play)
  (call/cc
   (lambda (win)
     (let ((first-move #t))
       (let loop ((board (random-board)) (color 'black)
                  (part1 #t) (from #f) (sel #f) (last #f))
         (when (eq? color 'white)
           (set! first-move #f))
         (let ((candidates
                (sort (if from
                          (let ((moves (all-moves-from board from part1)))
                            (map (lambda (m)
                                   (position-next board from
                                                  (direction (cdr m))))
                                 moves))
                          (let ((moves (all-moves board color part1)))
                            (delete-duplicates (map car moves))))
                      pos<)))
           (when (and part1 (null? candidates))
             (win (other-color color)))
           (unless (has-all-types? board 'black)
             (win 'white))
           (unless (has-all-types? board 'white)
             (win 'black))
           (when (null? candidates)
             (loop board (other-color color) #t #f #f last))
           (when (not sel)
             (set! sel (car candidates)))
           (draw-board (add-empty board)
                       (contract-highlights
                        (append (if last
                                    (list (cons (car last) 1)
                                          (cons (cdr last) 1))
                                    '())
                                (if from
                                    (list (cons from 2)
                                          (cons sel 4))
                                    (list (cons sel 2)))
                                (map (lambda (pos) (cons pos 3)) candidates))))
           ;; Input handler
           (case (read-char)
             ((#\j)
              (let ((next (cdr (member sel candidates))))
                (loop board color part1 from
                      (if (null? next)
                          (car candidates)
                          (car next))
                      last)))
             ((#\k)
              (let ((prev (cdr (member sel (reverse candidates)))))
                (loop board color part1 from
                      (if (null? prev)
                          (car (reverse candidates))
                          (car prev))
                      last)))
             ((#\l)
              (if from
                  (loop (make-move board (cons from sel))
                        (cond (first-move 'white)
                              (part1 color)
                              (else (other-color color)))
                        (if first-move #t (not part1))
                        #f #f (cons from sel))
                  (loop board color part1 sel #f last)))
             ((#\h)
              (if from
                  (loop board color part1 #f from last)
                  (loop board color part1 #f sel last)))
             ((#\p)
              (if part1
                  (loop board color #t from sel last)
                  (loop board (other-color color) #t #f #f last)))
             ((#\q) (win 'bye))
             (else (loop board color part1 from sel last)))))))))

(define (main)
  (init-screen)
  (print-winner (play))
  (restore-screen)
  (exit))

(main)