;; copyright: David Krentzlin <david@lisp-unleashed.de>
;;
;; 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.
;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



(module serial
(sn+ sn= sn< sn<= sn> sn>=)
(import chicken scheme)
(import (only extras fprintf))

(require-library mathh)
(import (only mathh log2))

(define +default-serial-bits+ 32)

(define (bits-needed-for fixnum)
  (if (zero? fixnum)
      0
      (inexact->exact (+ (floor (log2 fixnum)) 1))))

(define (boundary-for bits)
  (expt (- bits 1) 2))

(define (assert-valid-serial-number loc value bits)
  (unless (and (fixnum? value) (not (negative? value)))
    (error loc "the supplied value must be a non-negative fixnum" value))
  (when (> (bits-needed-for value) bits)
    (error loc "the supplied number exceeds defined bits" value bits)))

(define (sn+ sn fixnum #!key (bits +default-serial-bits+))
  
  (define (summand-out-of-bound? num bits)
    (> num (- (boundary-for bits) 1)))
  
  (assert-valid-serial-number 'sn+ sn bits)
  
  (unless (and (fixnum? fixnum) (not (negative? fixnum)))
    (error 'sn+ "the supplied value must be a non-negative fixnum" fixnum))

  (when (summand-out-of-bound? fixnum bits)
    (error 'sn+ "the supplied value exceeds the maximum size" fixnum))

  (modulo (+ sn fixnum) (expt bits 2)))

(define (sn= lhs rhs #!key (bits +default-serial-bits+))
  (assert-valid-serial-number 'sn= lhs bits)
  (assert-valid-serial-number 'sn= rhs bits)
  (= lhs rhs))


(define (sn< lhs rhs #!key (bits +default-serial-bits+))
  (assert-valid-serial-number 'sn< lhs bits)
  (assert-valid-serial-number 'sn< rhs bits)  
  (let ((boundary (boundary-for bits)))
    (or
     (and (< lhs rhs) (< (- rhs lhs) boundary))
     (and (> lhs rhs) (> (- lhs rhs) boundary)))))

(define (sn>= lhs rhs #!key (bits +default-serial-bits+))
  (assert-valid-serial-number 'sn>= lhs bits)
  (assert-valid-serial-number 'sn>= rhs bits)
  (or (sn= lhs rhs) (sn> lhs rhs)))

(define (sn> lhs rhs #!key (bits +default-serial-bits+))
  (assert-valid-serial-number 'sn> lhs bits)
  (assert-valid-serial-number 'sn> rhs bits)
  (let ((boundary (boundary-for bits)))
    (or
     (and (< lhs rhs) (> (- rhs lhs) boundary))
     (and (> lhs rhs) (< (- lhs rhs) boundary)))))

(define (sn<= lhs rhs #!key (bits +default-serial-bits+))
  (assert-valid-serial-number 'sn<= lhs bits)
  (assert-valid-serial-number 'sn<= rhs bits)
  (or (sn= lhs rhs) (sn< lhs rhs)))








)