;;;;
;;;; bitwiser.stk     -- Implementation of (scheme bitwise) aka SRFI-151
;;;;
;;;; Copyright © 2020 Jeronimo Pellegrini - <j_p@aleph0.info>
;;;;
;;;;
;;;; This program 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.
;;;;
;;;; This program 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 this program; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;; This file is a derivative work from the  implementation of
;;;; this SRFI by John Cowan, it is copyrighted as:
;;;;
;;;;;;  Copyright (c) 2019 John Cowan
;;;;;;  Permission is hereby granted, free of charge, to any person
;;;;;;  obtaining a copy of this software and associated documentation
;;;;;;  files (the "Software"), to deal in the Software without
;;;;;;  restriction, including without limitation the rights to use,
;;;;;;  copy, modify, merge, publish, distribute, sublicense, and/or
;;;;;;  sell copies of the Software, and to permit persons to whom the
;;;;;;  Software is furnished to do so, subject to the following
;;;;;;  conditions:
;;;;;;
;;;;;; The above copyright notice and this permission notice shall be
;;;;;; included in all copies or substantial portions of the Software.
;;;;;;
;;;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;;;;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;;;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;;;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;;;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;;;;;; OTHER DEALINGS IN THE SOFTWARE.
;;;;
;;;;           Author: Jeronimo Pellegrini [j_p@aleph0.info]
;;;;    Creation date: 08-Jul-2020 16:21 (jpellegrini)
;;;;

;;;; [EG] Use C primitives %bit-{and,or,xor} instead of Scheme functions
;;;;      bitwise-{and,ior,xor}. 

(define-module scheme/bitwise
  (import (srfi 60)
          (only SCHEME %bit-and %bit-or %bit-xor      ;; faster C primitives
                       bit-not))

  (export bitwise-not bitwise-and bitwise-ior bitwise-xor bitwise-eqv
          bitwise-nand bitwise-nor bitwise-andc1 bitwise-andc2
          bitwise-orc1 bitwise-orc2
          arithmetic-shift bit-count integer-length bitwise-if
          bit-set? copy-bit bit-swap any-bit-set? every-bit-set?  first-set-bit
          bit-field bit-field-any? bit-field-every?  bit-field-clear bit-field-set
          bit-field-replace  bit-field-replace-same
          bit-field-rotate bit-field-reverse
          bits->list list->bits bits->vector vector->bits bits
          bitwise-fold bitwise-for-each bitwise-unfold make-bitwise-generator)


;;; Using SRFI-60
(define bit-field-rotate rotate-bit-field)
(define bit-field-reverse reverse-bit-field)
(define (bits . args) (list->integer (reverse args)))
(define (list->bits lst) (list->integer (reverse lst)))

(define (bits->list k . len)
  (if (null? len)
      (reverse (integer->list k))
      (do ((idx (+ -1 (car len)) (+ -1 idx))
           (k k (arithmetic-shift k -1))
           (lst '() (cons (odd? k) lst)))
          ((negative? idx) (reverse lst)))))

;;;; bitwise-33 - Olin Shivers's code from SRFI-33 with modified names

;;; Olin Shivers is the sole author of this code, and he has placed it in
;;; the public domain.
;;;
;;; A good implementation might choose to provide direct compiler/interpreter
;;; support for these derived functions, or might simply define them to be
;;; integrable -- i.e., inline-expanded.
;;;
;;; The seven non-trivial boolean functions in terms
;;; of not, and, or & xor.

(define (bitwise-nand  i j)  (bit-not (%bit-and i j)))
(define (bitwise-nor   i j)  (bit-not (%bit-or i j)))
(define (bitwise-andc1 i j)  (%bit-and (bit-not i) j))
(define (bitwise-andc2 i j)  (%bit-and i (bit-not j)))
(define (bitwise-orc1  i j)  (%bit-or  (bit-not i) j))
(define (bitwise-orc2  i j)  (%bit-or  i (bit-not j)))

;;; This is a general definition, but less than efficient.  It should also
;;; receive primitive compiler/interpreter support so that the expensive
;;; n-ary mechanism is not invoked in the standard cases -- that is,
;;; an application of BITWISE-EQV should be rewritten into an equivalent
;;; tree applying some two-argument primitive to the arguments, in the
;;; same manner that statically-known n-ary applications of associative
;;; operations such as + and * are handled efficiently:
;;;   (bitwise-eqv)         => -1
;;;   (bitwise-eqv i)       => i
;;;   (bitwise-eqv i j)     => (%bitwise-eqv i j)
;;;   (bitwise-eqv i j k)   => (%bitwise-eqv (%bitwise-eqv i j) k)
;;;   (bitwise-eqv i j k l) => (%bitwise-eqv (%bitwise-eqv (%bitwise-eqv i j) k) l)

(define (bitwise-eqv . args)
  (let lp ((args args) (ans -1))
    (if (pair? args)
        (lp (cdr args) (bit-not (%bit-xor ans (car args))))
	ans)))

;;; Helper function -- make a mask of SIZE 1-bits, e.g. (%MASK 3) = #b111.
;;; Suppose your Scheme's fixnums are N bits wide (counting the sign bit,
;;; not counting any tag bits). This version, due to Marc Feeley, will
;;; handle SIZE in the range [0,N-1] without overflowing to bignums.
;;; (For SIZE >= N, the correct bignum value is also produced.)

(define (mask start end) (bit-not (arithmetic-shift -1 (- end start))))

;;; This alternate, mathematically-equivalent expression
;;;     (- (arithmetic-shift 1 size) 1)
;;; is not as good -- it only handles SIZE in the range [0,N-2] without
;;; overflowing to bignums.
;;;
;;; Finally, note that even Feeley's expression can't build an N-bit mask
;;; without bignum help. This is fundamental, since the interpretation
;;; of fixed-size fixnum bit patterns as semi-infinite-bit-strings is that
;;; you replicate the high bit out to infinity. So you have to have a
;;; zero "stop bit" appearing after that highest one bit to turn off the
;;; replication of the ones.

;;; STklos' SRFI60 already has this
;;;(define (bit-set? index n)
;;;  (not (zero? (bitwise-and (arithmetic-shift 1 index) n))))

(define (any-bit-set? test-bits n) (not (zero? (%bit-and test-bits n))))

(define (every-bit-set? test-bits n) (= test-bits (%bit-and test-bits n)))

;;; Bit-field ops

;;; STklos' SRFI60 already has this
;;;(define (bit-field n start end)
;;;  (bitwise-and (mask start end) (arithmetic-shift n (- start))))

(define (bit-field-any? n start end)
  (not (zero? (%bit-and (arithmetic-shift n (- start)) (mask start end)))))

;; Part of Olin's late revisions; code by John Cowan; public domain.
(define (bit-field-every? n start end)
  (let ((m (mask start end)))
    (eqv? m (%bit-and (arithmetic-shift n (- start)) m))))

;; Integrating i-b-f reduces nicely.
(define (bit-field-clear n start end)
  (bit-field-replace n 0 start end))

;; Counterpart to above, not in SRFI 33, written by John Cowan, public domain
(define (bit-field-set n start end)
  (bit-field-replace n -1 start end))

;;; Oops -- intermediate ARITHMETIC-SHIFT can fixnum-overflow on fixnum args.
;(define (bit-field-replace newfield n start end)
;  (bit-field-replace-same (arithmetic-shift newfield start) n start end))

;;; This three-line version won't fixnum-overflow on fixnum args.
(define (bit-field-replace n newfield start end)
  (let ((m (mask start end)))
    (%bit-or (%bit-and n (bit-not (arithmetic-shift m start)))
		 (arithmetic-shift (%bit-and newfield m) start))))

(define (bit-field-replace-same to from start end)
  (bitwise-if (arithmetic-shift (mask start end) start) from to))

;; Simple definition
;(define (first-set-bit i)
;  (and (not (zero? i))
;       (let lp ((j 0) (i start))
;         (if (bit-set? i 0) j
;             (lp (+ j 1) (arithmetic-shift i 1))))))

;;; Clever definition, assuming you have a fast BIT-COUNT.
;;; STklos already has this:
;;;(define (first-set-bit i) (- (bit-count (bitwise-xor i (- i 1))) 1))


  
;;;; bitwise-other - functions not from SRFI 33 or SRFI 60
;;; Copyright John Cowan 2017

(define bits->vector
  (case-lambda
    ((i) (list->vector (bits->list i)))
    ((i len) (list->vector (bits->list i len)))))

(define (vector->bits vector) (list->bits (vector->list vector)))

(define (bit-swap n1 n2 i)
  (let ((n1-bit (bit-set? n1 i))
        (n2-bit (bit-set? n2 i)))
    (copy-bit n2 (copy-bit n1 i n2-bit) n1-bit)))

(define (bitwise-fold proc seed i)
  (let ((len (integer-length i)))
    (let loop ((n 0) (r seed))
      (if (= n len)
        r
        (loop (+ n 1) (proc (bit-set? n i) r))))))

(define (bitwise-for-each proc i)
  (let ((len (integer-length i)))
    (let loop ((n 0))
      (when (< n len)
        (proc (bit-set? n i))
        (loop (+ n 1))))))

(define (bitwise-unfold stop? mapper successor seed)
  (let loop ((n 0) (result 0) (state seed))
    (if (stop? state)
      result
        (loop (+ n 1)
              (copy-bit n result (mapper state))
              (successor state)))))

(define (make-bitwise-generator i)
  (lambda ()
    (let ((bit (bit-set? 0 i)))
       (set! i (arithmetic-shift i -1))
       bit)))

) ;; END OF DEFINE-MODULE
;;;; ======================================================================

(provide "scheme/bitwise")
