guile-bitboard/bitboard-operations.scm

;; =====
;; Notes
;; =====

;; The abbreviation `bb` in identifiers stands for "bitboard".

(define-module (bitboard-operations))


(use-modules
 ;; SRFI 60: procedures for treating integers as bits
 (srfi srfi-60)
 ((bit-integer-operations) #:prefix bio:)
 ((bitboard-model) #:prefix bbm:)
 ((coords-model) #:prefix cm:)
 ((coords-operations) #:prefix co:))


;; =============================
;; BIT INTEGER ABSTRACTION LAYER
;; =============================

;; This code is an abstraction layer over the fact, that the bit board
;; implementation uses integers to represent the state of the bit board. This is
;; useful, in the case, that the representation changes. In such case one
;; hopefully only needs to adapt this code, rather than all bit board
;; operations.


(define-public get-bb-value-at-pos
  (λ (bb pos)
    (cond
     [(> pos (* (bbm:bb-height bb) (bbm:bb-width bb)))
      (throw 'index-error "index out of range for given bit board" bb pos)]
     [else
      (bio:get-bit-value-at-pos (bbm:bb-bits bb) pos)])))


(define-public get-bb-value-at-coords
  (λ (bb coords)
    (let ([height (bbm:bb-height bb)]
          [width (bbm:bb-width bb)]
          [row-ind (cm:get-row-part coords)]
          [col-ind (cm:get-col-part coords)])
      (cond
       [(> (cm:get-row-part coords) (- height 1))
        (throw 'index-error
               "row index out of range for given bit board"
               bb
               row-ind)]
       [(> (cm:get-col-part coords) (- height 1))
        (throw 'index-error
               "column index out of range for given bit board"
               bb
               col-ind)]
       [else
        (bio:get-bit-value-at-pos
         (bbm:bb-bits bb)
         (co:coords->index (cm:get-row-part coords)
                           (cm:get-col-part coords)
                           (bbm:bb-height bb)
                           (bbm:bb-width bb)))]))))


(define-public bb-fold
  (λ (bb proc init)
    (let* ([int (bbm:bb-bits bb)]
           [int-length (integer-length int)])
      (let iter ([accumulated init] [pos 0])
        (cond
         [(< pos int-length)
          (iter (proc accumulated (bio:get-bit-value-at-pos int pos))
                (+ pos 1))]
         [else accumulated])))))


(define-public bb-and
  (λ (bb1 bb2)
    "This procedure does a bitwise logical and operation of the bits of 2
bitboards and returns the result as a new bitboard."
    (bbm:make-bb
     (bitwise-and (bbm:bb-bits bb1) (bbm:bb-bits bb2))
     (bbm:bb-height bb1)
     (bbm:bb-width bb1)
     (bbm:bb-kind bb1))))


(define-public bb-or
  (λ (bb1 bb2)
    "This procedure does a bitwise logical or operation of the bits of 2 bitboards
and returns the result as a new bitboard."
    (bbm:make-bb
     (bitwise-ior (bbm:bb-bits bb1) (bbm:bb-bits bb2))
     (bbm:bb-height bb1)
     (bbm:bb-width bb1)
     (bbm:bb-kind bb1))))


(define-public bb-not
  (λ (bb)
    "This procedure does a bitwise not and operation of the bits of a bitboard and
returns the result as a new bitboard."
    (bbm:make-bb
     (bitwise-not (bbm:bb-bits bb))
     (bbm:bb-height bb)
     (bbm:bb-width bb)
     (bbm:bb-kind bb))))


(define-public bb-xor
  (λ (bb1 bb2)
    "This procedure does a bitwise logical xor operation of the bits of 2 bitboards
and returns the result as a new bitboard."
    (bbm:make-bb
     (bitwise-xor (bbm:bb-bits bb1) (bbm:bb-bits bb2))
     (bbm:bb-height bb1)
     (bbm:bb-width bb1)
     (bbm:bb-kind bb1))))


(define-public bb-any?
  (λ (bb)
    "This procedure checks, if there is any bit #t in the bitvector and returns #t,
if there is any and #f, if there is none."
    (not (= (bbm:bb-bits bb) 0))))


(define-public bb-all?
  (λ (bb)
    "This procedure checks, if all bits in a bitboard are #t."
    (= (bbm:bb-bits bb)
       (bio:max-int (* (bbm:bb-height bb)
                       (bbm:bb-width bb))))))


(define-public display-bb-bits
  (lambda* (bb #:optional (port (current-output-port)))
    "This procedure displays the bits of a bit board."
    (display
     (call-with-output-string
       (λ (inner-port)
         (bio:display-bit-integer (bbm:bb-bits bb)
                                  inner-port
                                  #:newline #f
                                  #:padding-char #\0)))
     port)))

;; =====
;; OTHER
;; =====

;; These procedures shall not rely on any representation of the bits of a bit
;; board, but instead shall use only procedures of the abstraction layer.

(define-public display-bb
  (lambda* (bb #:optional (port (current-output-port)))
    "Displays a bitboard in a human readable way."
    (display
     (simple-format #f
                    "Bitbard: <bits: ~a, height: ~a, width: ~a, kind: ~s>"
                    (call-with-output-string
                      (λ (port)
                        (display-bb-bits bb port)))
                    (bbm:bb-height bb)
                    (bbm:bb-width bb)
                    (bbm:bb-kind bb))
     port)))


(define-public get-coords-of-trues
  (λ (bb)
    (let* ([height (bbm:bb-height bb)]
           [width (bbm:bb-width bb)]
           [int-length (* height width)]
           [int-bits (bbm:bb-bits bb)])
      (let iter ([pos 0] [one-bit-coords '()])
        (cond
         [(>= pos int-length) one-bit-coords]
         [(bit-set? pos int-bits)
          (iter (+ pos 1)
                (cons (co:index->coords pos height width)
                      one-bit-coords))]
         [else
          (iter (+ pos 1) one-bit-coords)])))))


(define index->board-coords
  (λ (index bb)
    (let ([height (bbm:bb-height bb)] [width (bbm:bb-width bb)])
      (co:index->coords index height width))))