;;;; bitwise-utils.scm  -*- Scheme -*-
;;;; Kon Lovett, Apr '20

;;;; Issues
;;
;; - Portions from C4 srfi-60

;;;; "logical.scm", bit access and operations for integers for Scheme
;;; Copyright (C) 1991, 1993, 2001, 2003, 2005 Aubrey Jaffer
;
;Permission to copy this software, to modify it, to redistribute it,
;to distribute modified versions, and to use it for any purpose is
;granted, subject to the following restrictions and understandings.
;
;1.  Any copy made of this software must include this copyright notice
;in full.
;
;2.  I have made no warranty or representation that the operation of
;this software will be error-free, and I am under no obligation to
;provide any services, by way of maintenance, update, or otherwise.
;
;3.  In conjunction with products arising from the use of this
;material, there shall be no use of my name in any advertising,
;promotional, or sales literature without prior written consent in
;each case.

(module bitwise-utils

(;export
  arithmetic-shift-left arithmetic-shift-right
  logical-shift-left logical-shift-right
  bitwise-zeros bitwise-ones
  bitwise-abs
  bitwise-drop-right
  bitwise-cons
  bitwise-mask
  bitwise-join
  bitwise-split
  bitwise-count
  bitwise-merge
  bitwise-any? bitwise-nth? bitwise-first-set bitwise-set-nth
  bitwise-reverse bitwise-rotate
  bitwise-field bitwise-field-copy bitwise-field-reverse bitwise-field-rotate
  integer->list list->integer)

(import scheme)
(import (only (chicken base) declare fixnum? foldl cut define-inline define-constant))
(import (only (chicken fixnum) most-positive-fixnum fxneg fx= fx> fx<= fx- fx+ fx* fxmod))
(import (chicken type))
(import (chicken foreign))
(import (only (chicken bitwise) integer-length arithmetic-shift bit->boolean
                                bitwise-not bitwise-and bitwise-ior))

;;

;FIXME bitwise-split more like string-chop then string-split

(: arithmetic-shift-left    (integer fixnum --> integer))
(: arithmetic-shift-right   (integer fixnum --> integer))
(: logical-shift-left       (integer fixnum --> integer))
(: logical-shift-right      (integer fixnum --> integer))
(: bitwise-zeros            (fixnum --> integer))
(: bitwise-ones             (fixnum --> integer))
(: bitwise-abs              (integer --> integer))
(: bitwise-drop-right       (integer fixnum --> integer))
(: bitwise-cons             (integer integer --> integer))
(: bitwise-mask             (fixnum #!optional boolean --> integer))
(: bitwise-join             (integer #!rest integer --> integer))
(: bitwise-split            (integer fixnum --> (list-of integer)))
(: bitwise-count            (integer --> fixnum))
(: bitwise-merge            (integer integer integer --> integer))
(: bitwise-nth?             (integer fixnum --> boolean))
(: bitwise-any?             (integer integer --> boolean))
(: bitwise-first-set        (integer --> fixnum))
(: bitwise-reverse          (integer fixnum --> integer))
(: bitwise-rotate           (integer fixnum fixnum --> integer))
(: bitwise-set-nth          (integer fixnum boolean --> integer))
(: bitwise-field            (integer fixnum fixnum --> integer))
(: bitwise-field-copy       (integer integer fixnum fixnum --> integer))
(: bitwise-field-reverse    (integer fixnum fixnum --> integer))
(: bitwise-field-rotate     (integer fixnum fixnum fixnum --> integer))
(: integer->list            (integer #!optional fixnum --> (list-of boolean)))
(: list->integer            (list --> integer))

;;

;fx-inlines
(define-inline (fxzero? n) (fx= 0 n))
(define (fxnegative? n) (fx> 0 n))
(define-inline (fxsub1 n) (fx- n 1))

;;

;observes sign - does sign extend
(define arithmetic-shift-left arithmetic-shift)
(define (arithmetic-shift-right n w) (arithmetic-shift n (fxneg w)))

(define (bitwise-zeros b) (arithmetic-shift-left -1 b))
(define (bitwise-ones b) (bitwise-not (bitwise-zeros b)))

(define (bitwise-abs n) (if (negative? n) (bitwise-not n) n))

(define (bitwise-drop-right n w)
  (bitwise-and (arithmetic-shift-right n w)
               (bitwise-ones (fx- (integer-length n) w))) )

;preserves sign - doesn't sign extend
(define logical-shift-left arithmetic-shift-left)
(define (logical-shift-right n w)
  (if (fxzero? w) n
      (let ((res (bitwise-drop-right (abs n) w)))
        (if (negative? n) (- res) res) ) ) )

(define (bitwise-cons a b)
  (bitwise-ior (logical-shift-left a (integer-length b))
               b) )

;5 #t => +0...011111
;5 #f => -1...100000
(define (bitwise-mask b #!optional (on? #t))
  (if on? (bitwise-ones b)
      (bitwise-zeros b)) )

;#b10 #b0000001 #b101 => #b101101
(define (bitwise-join n . ns)
  (foldl bitwise-cons n ns) )

;babcdef 2 => ba bc de f
;0 2 => '()
;123 0 => '()
(define (bitwise-split n w)
  (if (or (zero? n) (fxzero? w)) `(,n)
      (let ((neg? (negative? n)) (mask (bitwise-ones w)))
        (let loop ((n (abs n)) (ns '()))
          (if (zero? n)
              (if neg? (map - ns) ns)
              (loop (bitwise-drop-right n w) (cons (bitwise-and n mask) ns)) ) ) ) ) )

#>
#define TWO( c )       (((C_uword) 1u) << (c))
#define MASK( c )      (((C_uword) -1) / (TWO( TWO( c ) ) + 1u))
#define COUNT( x, c )  ((x) & MASK( c )) + (((x) >> (TWO( c ))) & MASK( c ))
<#

(cond-expand
  (64bit
    (define-constant UWORD-SIZE 8)
    (define uword-bitwise-count
      (foreign-lambda* unsigned-int ((unsigned-integer64 n)) "
        if (0 == n) C_return( (unsigned int) 0 );
        n = COUNT( n, 0 );
        n = COUNT( n, 1 );
        n = COUNT( n, 2 );
        n = COUNT( n, 3 );
        n = COUNT( n, 4 );
        n = COUNT( n, 5 );
        return( n );")) )
  (else ;32bit
    (define-constant UWORD-SIZE 4)
    (define uword-bitwise-count
      (foreign-lambda* unsigned-int ((unsigned-integer32 n)) "
        if (0 == n) C_return( (unsigned int) 0 );
        n = COUNT( n, 0 );
        n = COUNT( n, 1 );
        n = COUNT( n, 2 );
        n = COUNT( n, 3 );
        n = COUNT( n, 4 );
        return( n );")) ) )

#|
#>
#undef COUNT
#undef MASK
#undef TWO
<#
|#

(define-constant UWORD-BITS-SIZE (* 8 UWORD-SIZE))

(define (integer->uwords n) (bitwise-split n UWORD-BITS-SIZE))

(define (add-uword-bits c n) (fx+ c (uword-bitwise-count n)))

;-> (string-length (string-delete #\0 (number->string n 2)))
(define (bitwise-count n)
  (let ((n (bitwise-abs n)))
    (if (fixnum? n)
        (uword-bitwise-count n)
        (foldl add-uword-bits 0 (integer->uwords n)) ) ) )

(define (bitwise-merge mask n0 n1)
  (bitwise-ior (bitwise-and mask n0)
               (bitwise-and (bitwise-not mask) n1)) )

(define (bitwise-nth? index n) (bit->boolean n index))

(define (bitwise-any? n1 n2) (not (zero? (bitwise-and n1 n2))))

(define (bitwise-first-set n) (fxsub1 (integer-length (bitwise-and n (- n)))))

(define (bitwise-reverse n k)
  (do ((m (bitwise-abs n) (arithmetic-shift m -1))
       (k (fxsub1 k) (fxsub1 k))
       (rvs 0 (bitwise-ior (arithmetic-shift rvs 1) (bitwise-and 1 m))) )
      ((fxnegative? k) (if (negative? n) (bitwise-not rvs) rvs)) ) )

(define (bitwise-rotate k count len) (bitwise-field-rotate k count 0 len))

(define (bitwise-set-nth to index on?)
  (if on?
      (bitwise-ior to (arithmetic-shift 1 index))
      (bitwise-and to (bitwise-not (arithmetic-shift 1 index))) ) )

(define (bitwise-field n start end)
  (bitwise-and (bitwise-not (arithmetic-shift -1 (fx- end start)))
               (arithmetic-shift-right n start)) )

(define (bitwise-field-copy to from start end)
  (bitwise-merge (arithmetic-shift (bitwise-not (arithmetic-shift -1 (fx- end start)))
                                   start)
                 (arithmetic-shift from start)
                 to) )

(define (bitwise-field-reverse n start end)
  (let* ((width (fx- end start))
         (mask (bitwise-ones width))
         (zn (bitwise-and mask (arithmetic-shift-right n start))) )
    (bitwise-ior (arithmetic-shift (bitwise-reverse zn width) start)
                 (bitwise-and (bitwise-not (arithmetic-shift mask start)) n)) ) )

(define (bitwise-field-rotate n count start end)
  (let* ((width (fx- end start))
         (count (fxmod count width))
         (mask (bitwise-ones width))
         (zn (bitwise-and mask (arithmetic-shift-right n start))) )
    (bitwise-ior
      (arithmetic-shift
        (bitwise-ior (bitwise-and mask (arithmetic-shift zn count))
                     (arithmetic-shift zn (fx- count width)))
        start)
      (bitwise-and (bitwise-not (arithmetic-shift mask start)) n)) ) )

;NOTE rather than an {{integer-length}} {{len}} arg default, an unlimited length
;with a zero termination condition amount to the same thing
(define (integer->list k #!optional (len most-positive-fixnum))
  (do ((idx len (fxsub1 idx))
       (k k (arithmetic-shift k -1))
       (lst '() (cons (not (zero? (bitwise-and k 1))) lst)) )
      ((or (<= k 0) (fx<= idx 0)) lst)) )

(define (list->integer bools)
  (do ((bs bools (cdr bs))
       (acc 0 (+ acc acc (if (car bs) 1 0))) )
      ((null? bs) acc)) )

) ;bitwise-utils