;;;; string-hexadecimal.scm  -*- Scheme -*-
;;;; Kon Lovett, Jul '18
;;;; Kon Lovett, Aug '17
;;;; Kon Lovett, Aug '10

#>
static void
bv_to_hex( uint8_t *out, uint8_t *in, int off, int len )
{
  static char digits[] = "0123456789abcdef";

  in += off;
  while( len-- ) {
    *out++ = digits[ *in >> 4 ];
    *out++ = digits[ *in++ & 0x0f ];
  }
}

static void
hex_to_bv( uint8_t *out, uint8_t *in, int off, int len )
{
# define hex_nibble(c)  (isdigit(c) ? ((c) - '0') : (((c) - 'a') + 10))

  in += off;
  while( 0 <= (len -= 2) ) {
    unsigned char in0 = tolower( in[0] );
    unsigned char in1 = tolower( in[1] );
    *out++ = (hex_nibble( in0 ) << 4) | hex_nibble( in1 );
    in += 2;
  }

# undef hex_nibble
}
<#

(declare
  (bound-to-procedure
    ##sys#signal-hook
    ##sys#make-string))

(module string-hexadecimal

(;export
  ;
  mem_to_hex
  s8vec_to_hex
  u8vec_to_hex
  blob_to_hex
  str_to_hex
  ;
  hex_to_str
  hex_to_blob
  ;
  string->hex *string->hex
  hex->string *hex->string)

(import scheme
  (chicken base)
  (chicken fixnum)
  (chicken type)
  (chicken foreign)
  (chicken memory representation)
  (only type-checks check-natural-fixnum check-string))

;;;

(define-inline (fxzero? x)
  (fx= 0 x) )

;;;

(define (check-subvector-indexes loc start end)
  (unless
    (fx<=
      (check-natural-fixnum loc start 'start)
      (check-natural-fixnum loc end 'end))
    (##sys#signal-hook #:bounds-error loc "illegal subvector specification" start end) ) )

;;

(define C_str_to_hex
  (foreign-lambda void "bv_to_hex" nonnull-scheme-pointer nonnull-scheme-pointer int int))

(define C_blob_to_hex
  (foreign-lambda void "bv_to_hex" nonnull-scheme-pointer nonnull-blob int int))

(define C_u8vec_to_hex
  (foreign-lambda void "bv_to_hex" nonnull-scheme-pointer nonnull-u8vector int int))

(define C_s8vec_to_hex
  (foreign-lambda*
      void ((nonnull-scheme-pointer out) (nonnull-s8vector in) (int off) (int len))
    "bv_to_hex( out, ((uint8_t *) in), off, len );"))

(define C_mem_to_hex
  (foreign-lambda void "bv_to_hex" nonnull-scheme-pointer nonnull-c-pointer int int))

;;

(define C_hex_to_str
  (foreign-lambda void "hex_to_bv" nonnull-scheme-pointer nonnull-scheme-pointer int int))

;;

(: str_to_hex (string string fixnum fixnum -> string))
;
(define (str_to_hex out in off len)
  (C_str_to_hex out in off len)
  out )

(: blob_to_hex (string blob fixnum fixnum -> string))
;
(define (blob_to_hex out in off len)
  (C_blob_to_hex out in off len)
  out )

(: u8vec_to_hex (string u8vector fixnum fixnum -> string))
;
(define (u8vec_to_hex out in off len)
  (C_u8vec_to_hex out in off len)
  out )

(: s8vec_to_hex (string s8vector fixnum fixnum -> string))
;
(define (s8vec_to_hex out in off len)
  (C_s8vec_to_hex out in off len)
  out )

(: mem_to_hex (string pointer fixnum fixnum -> string))
;
(define (mem_to_hex out in off len)
  (C_mem_to_hex out in off len)
  out )

;;

(: hex_to_str (string string fixnum fixnum -> string))
;
(define (hex_to_str out in off len)
  (C_hex_to_str out in off len)
  out )

(: hex_to_blob (blob string fixnum fixnum -> blob))
;
(define (hex_to_blob out in off len)
  (C_hex_to_str out in off len)
  out )


;;

(: string->hex (string #!optional fixnum (or boolean fixnum) --> string))
;
(define (string->hex str #!optional (start 0) (end #f))
  (check-string 'string->hex str)
  (let ((end (or end (number-of-bytes str))))
    (check-subvector-indexes 'string->hex start end)
    (*string->hex str start end) ) )

(: hex->string (string #!optional fixnum --> string))
;
(define (hex->string str #!optional (start 0) (end #f))
  (let ((len (number-of-bytes (check-string 'hex->string str))))
    (unless (fxzero? (fxmod len 2))
      (error 'hex->string "too few characters" str) )
    (let ((end (or end len)))
      (check-subvector-indexes 'hex->string start end)
      (*hex->string str start end) ) ) )

;;

(: *string->hex (string fixnum fixnum --> string))
;
(define (*string->hex str start end)
  (let ((len (fx- end start)))
    (if (fxzero? len)
      ""
      (str_to_hex (##sys#make-string (fx* len 2)) str start len) ) ) )

(: *hex->string (string fixnum fixnum --> string))
;
(define (*hex->string str start end)
  (let ((len (fx- end start)))
    (if (fxzero? len)
      ""
      (hex_to_str (##sys#make-string (fx/ len 2)) str start len) ) ) )

#|
(use
  (only (srfi 1) drop drop-right)
  (only (srfi 13) string-pad string-concatenate  reverse-list->string))

(define (*string->hex str start end)
  (let* ((ls (string->list str) )
         (ls (drop ls start) )
         (strlen (string-length str) )
         (ls (drop-right ls (fx- strlen end)) ) )
    (string-concatenate
      (map
        (lambda (c)
          (string-pad (number->string (char->integer c) 16) 2 #\0))
      ls)) ) )

(define (*hex->string str)
  (let ((len (string-length str)))
    (let loop ((i 0) (ls '()))
      (if (fx<= len i)
        (reverse-list->string ls)
        (let ((ni (fx+ i 2) ))
          (loop ni (cons (integer->char (string->number (substring str i ni) 16)) ls)) ) ) ) ) )
|#

) ;module string-hexadecimal