diff --git a/xenomorph/xenomorph/number.rkt b/xenomorph/xenomorph/number.rkt index 4a124c45..b555c926 100644 --- a/xenomorph/xenomorph/number.rkt +++ b/xenomorph/xenomorph/number.rkt @@ -28,53 +28,6 @@ https://github.com/mbutterick/restructure/blob/master/src/Number.coffee (define (exact-if-possible x) (if (integer? x) (inexact->exact x) x)) (define system-endian (if (system-big-endian?) 'be 'le)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; structing - -(struct $integer (bytes signed endian) #:transparent) - -(define (+$integer [bytes 2] [signed #false] [endian system-endian]) - ($integer bytes signed endian)) - -(define $int16 (+$integer)) - -(define ($bits int) (* ($integer-bytes int) 8)) - -(define ($bounds int) - ;; if a signed integer has n bits, it can contain a number - ;; between - (expt 2 (sub1 n)) and (sub1 (expt 2 (sub1 n)). - (let* ([signed-max (sub1 (arithmetic-shift 1 (sub1 ($bits int))))] - [signed-min (sub1 (- signed-max))] - [delta (if ($integer-signed int) 0 signed-min)]) - (values (- signed-min delta) (- signed-max delta)))) - -(define ($decode int [port-arg (current-input-port)]) - (define bstr (read-bytes ($integer-bytes int) (->input-port port-arg))) - (define bs ((if (eq? ($integer-endian int) system-endian) - values - reverse-bytes) bstr)) - (define uint (for/sum ([b (in-bytes bs)] - [i (in-naturals)]) - (arithmetic-shift b (* 8 i)))) - (if ($integer-signed int) (unsigned->signed uint ($bits int)) uint)) - -(define ($encode int val [port-arg #f]) - (define-values (bound-min bound-max) ($bounds int)) - (unless (<= bound-min val bound-max) - (raise-argument-error '$encode (format "value within range of ~a ~a-byte int (~a to ~a)" (if ($integer-signed int) "signed" "unsigned") ($integer-bytes int) bound-min bound-max) val)) - (define-values (bs _) - (for/fold ([bs null] - [n (exact-if-possible val)]) - ([i (in-range ($integer-bytes int))]) - (values (cons (bitwise-and n #xff) bs) (arithmetic-shift n -8)))) - (define res (apply bytes ((if (eq? ($integer-endian int) 'be) values reverse) bs))) - (if (and port-arg (output-port? port-arg)) - (write-bytes res port-arg) - res)) - -($decode $int16 ($encode $int16 123)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (define-subclass xenomorph-base% (Integer [type 'uint16] [endian system-endian]) (getter-field [number-type (string->symbol (format "~a~a" type (if (ends-with-8? type) "" endian)))]) (define _signed? (signed-type? type)) diff --git a/xenomorph/xenomorph/redo/number.rkt b/xenomorph/xenomorph/redo/number.rkt index 461cb166..88d2f706 100644 --- a/xenomorph/xenomorph/redo/number.rkt +++ b/xenomorph/xenomorph/redo/number.rkt @@ -1,4 +1,4 @@ -#lang racket/base +#lang debug racket/base (require "base.rkt") (provide (all-defined-out)) @@ -6,75 +6,96 @@ (define system-endian (if (system-big-endian?) 'be 'le)) -(define (int-encode i val [port #f]) - (unless (int? i) - (raise-argument-error 'encode "integer instance" i)) +(define (xint-encode i val [port #f]) + (unless (xint? i) + (raise-argument-error 'encode "xint instance" i)) (define-values (bound-min bound-max) (bounds i)) (unless (<= bound-min val bound-max) - (raise-argument-error 'encode (format "value that fits within ~a ~a-byte int (~a to ~a)" (if (int-signed i) "signed" "unsigned") (int-size i) bound-min bound-max) val)) + (raise-argument-error 'encode (format "value that fits within ~a ~a-byte int (~a to ~a)" (if (xint-signed i) "signed" "unsigned") (xint-size i) bound-min bound-max) val)) (unless (or (not port) (output-port? port)) (raise-argument-error 'encode "output port or #f" port)) (define bs (for/fold ([bs null] [val (exact-if-possible val)] #:result bs) - ([i (in-range (int-size i))]) + ([i (in-range (xint-size i))]) (values (cons (bitwise-and val #xff) bs) (arithmetic-shift val -8)))) - (define res (apply bytes ((if (eq? (int-endian i) 'be) values reverse) bs))) + (define res (apply bytes ((if (eq? (xint-endian i) 'be) values reverse) bs))) (if port (write-bytes res port) res)) -(define (int-decode i [port-arg (current-input-port)]) - (unless (int? i) - (raise-argument-error 'decode "integer instance" i)) - (define bstr (read-bytes (int-size i) (->input-port port-arg))) - (define bs ((if (eq? (int-endian i) system-endian) +(define (xint-decode i [port-arg (current-input-port)]) + (unless (xint? i) + (raise-argument-error 'decode "xint instance" i)) + (define bstr (read-bytes (xint-size i) (->input-port port-arg))) + (define bs ((if (eq? (xint-endian i) system-endian) values reverse-bytes) bstr)) (define uint (for/sum ([b (in-bytes bs)] [i (in-naturals)]) (arithmetic-shift b (* 8 i)))) - (if (int-signed i) (unsigned->signed uint (bits i)) uint)) + (if (xint-signed i) (unsigned->signed uint (bits i)) uint)) -(struct int (size signed endian) #:transparent +(struct xnumber () #:transparent) + +(struct xint xnumber (size signed endian) #:transparent #:methods gen:xenomorphic - [(define decode int-decode) - (define encode int-encode) - (define size (λ (i) (int-size i)))]) + [(define decode xint-decode) + (define encode xint-encode) + (define size (λ (i) (xint-size i)))]) -(define (+integer [size 2] [signed #false] [endian system-endian]) +(define (+xint [size 2] #:signed [signed #true] #:endian [endian system-endian]) (unless (exact-positive-integer? size) - (raise-argument-error '+integer "exact positive integer" size)) - (unless (boolean? signed) - (raise-argument-error '+integer "boolean" signed)) + (raise-argument-error '+xint "exact positive integer" size)) (unless (memq endian '(le be)) - (raise-argument-error '+integer "'le or 'be" endian)) - (int size signed endian)) + (raise-argument-error '+xint "'le or 'be" endian)) + (xint size signed endian)) (define (type-tag i) (string->symbol - (string-append (if (int-signed i) "" "u") + (string-append (if (xint-signed i) "" "u") "int" (number->string (bits i)) - (if (> (int-size i) 1) (symbol->string (int-endian i)) "")))) + (if (> (xint-size i) 1) (symbol->string (xint-endian i)) "")))) -(define (bits i) (* (int-size i) 8)) +(define (bits i) (* (xint-size i) 8)) (define (bounds i) - (unless (int? i) + (unless (xint? i) (raise-argument-error 'bounds "integer instance" i)) ;; if a signed integer has n bits, it can contain a number ;; between - (expt 2 (sub1 n)) and (sub1 (expt 2 (sub1 n)). (let* ([signed-max (sub1 (arithmetic-shift 1 (sub1 (bits i))))] [signed-min (sub1 (- signed-max))] - [delta (if (int-signed i) 0 signed-min)]) + [delta (if (xint-signed i) 0 signed-min)]) (values (- signed-min delta) (- signed-max delta)))) -(define uint8 (+integer 1)) -(define int8 (+integer 1 #t)) -(define uint16 (+integer 2)) +(define int8 (+xint 1)) +(define int16 (+xint 2)) +(define int24 (+xint 3)) +(define int32 (+xint 4)) +(define uint8 (+xint 1 #:signed #f)) +(define uint16 (+xint 2 #:signed #f)) +(define uint24 (+xint 3 #:signed #f)) +(define uint32 (+xint 4 #:signed #f)) +(define int8be (+xint 1 #:endian 'be)) +(define int16be (+xint 2 #:endian 'be)) +(define int24be (+xint 3 #:endian 'be)) +(define int32be (+xint 4 #:endian 'be)) +(define uint8be (+xint 1 #:signed #f #:endian 'be)) +(define uint16be (+xint 2 #:signed #f #:endian 'be)) +(define uint24be (+xint 3 #:signed #f #:endian 'be)) +(define uint32be (+xint 4 #:signed #f #:endian 'be)) +(define int8le (+xint 1 #:endian 'le)) +(define int16le (+xint 2 #:endian 'le)) +(define int24le (+xint 3 #:endian 'le)) +(define int32le (+xint 4 #:endian 'le)) +(define uint8le (+xint 1 #:signed #f #:endian 'le)) +(define uint16le (+xint 2 #:signed #f #:endian 'le)) +(define uint24le (+xint 3 #:signed #f #:endian 'le)) +(define uint32le (+xint 4 #:signed #f #:endian 'le)) (module+ test (require rackunit) - (check-exn exn:fail:contract? (λ () (+integer 'not-a-valid-type))) + (check-exn exn:fail:contract? (λ () (+xint 'not-a-valid-type))) (check-exn exn:fail:contract? (λ () (encode uint8 256))) (check-not-exn (λ () (encode uint8 255))) (check-exn exn:fail:contract? (λ () (encode int8 256))) @@ -85,7 +106,7 @@ (check-exn exn:fail:contract? (λ () (encode uint16 (add1 #xffff)))) (check-not-exn (λ () (encode uint16 #xffff))) - (let ([i (+integer 2 #false 'le)] + (let ([i (+xint 2 #:signed #f #:endian 'le)] [ip (open-input-bytes (bytes 1 2 3 4))] [op (open-output-bytes)]) (check-equal? (decode i ip) 513) ;; 1000 0000 0100 0000 @@ -95,7 +116,7 @@ (encode i 1027 op) (check-equal? (get-output-bytes op) (bytes 1 2 3 4))) - (let ([i (+integer 2 #false 'be)] + (let ([i (+xint 2 #:signed #f #:endian 'be)] [ip (open-input-bytes (bytes 1 2 3 4))] [op (open-output-bytes)]) (check-equal? (decode i ip) 258) ;; 0100 0000 1000 0000 @@ -105,12 +126,89 @@ (encode i 772 op) (check-equal? (get-output-bytes op) (bytes 1 2 3 4))) - (check-equal? (size (+integer 1) ) 1) - (check-equal? (size (+integer)) 2) - (check-equal? (size (+integer 4)) 4) - (check-equal? (size (+integer 8)) 8) + (check-equal? (size (+xint 1)) 1) + (check-equal? (size (+xint)) 2) + (check-equal? (size (+xint 4)) 4) + (check-equal? (size (+xint 8)) 8) (check-equal? (decode int8 (bytes 127)) 127) (check-equal? (decode int8 (bytes 255)) -1) (check-equal? (encode int8 -1) (bytes 255)) - (check-equal? (encode int8 127) (bytes 127))) \ No newline at end of file + (check-equal? (encode int8 127) (bytes 127))) + +(define (xfloat-decode xf [port-arg (current-input-port)]) + (unless (xfloat? xf) + (raise-argument-error 'decode "xfloat instance" xf)) + (define bs (read-bytes (xfloat-size xf) (->input-port port-arg))) + (floating-point-bytes->real bs (eq? (xfloat-endian xf) 'be))) + +(define (xfloat-encode xf val [port #f]) + (unless (xfloat? xf) + (raise-argument-error 'encode "xfloat instance" xf)) + (unless (or (not port) (output-port? port)) + (raise-argument-error 'encode "output port or #f" port)) + (define res (real->floating-point-bytes val (xfloat-size xf) (eq? (xfloat-endian xf) 'be))) + (if port (write-bytes res port) res)) + +(struct xfloat xnumber (size endian) #:transparent + #:methods gen:xenomorphic + [(define decode xfloat-decode) + (define encode xfloat-encode) + (define size (λ (i) (xfloat-size i)))]) + +(define (+xfloat [size 4] #:endian [endian system-endian]) + (unless (exact-positive-integer? size) + (raise-argument-error '+xfloat "exact positive integer" size)) + (unless (memq endian '(le be)) + (raise-argument-error '+xfloat "'le or 'be" endian)) + (xfloat size endian)) + +(define float (+xfloat 4)) +(define floatbe (+xfloat 4 #:endian 'be)) +(define floatle (+xfloat 4 #:endian 'le)) + +(define double (+xfloat 8)) +(define doublebe (+xfloat 8 #:endian 'be)) +(define doublele (+xfloat 8 #:endian 'le)) + +(define (xfixed-decode xf [port-arg (current-input-port)]) + (unless (xfixed? xf) + (raise-argument-error 'decode "xfixed instance" xf)) + (define int (xint-decode xf port-arg)) + (exact-if-possible (/ int (fixed-shift xf) 1.0))) + +(define (xfixed-encode xf val [port #f]) + (unless (xfixed? xf) + (raise-argument-error 'encode "xfixed instance" xf)) + (define int (exact-if-possible (floor (* val (fixed-shift xf))))) + (xint-encode xf int port)) + +(struct xfixed xint (fracbits) #:transparent + #:methods gen:xenomorphic + [(define decode xfixed-decode) + (define encode xfixed-encode) + (define size (λ (i) (xint-size i)))]) + +(define (+xfixed [size 2] #:signed [signed #true] #:endian [endian system-endian] [fracbits (/ (* size 8) 2)]) + (unless (exact-positive-integer? size) + (raise-argument-error '+xfixed "exact positive integer" size)) + (unless (exact-positive-integer? fracbits) + (raise-argument-error '+xfixed "exact positive integer" fracbits)) + (unless (memq endian '(le be)) + (raise-argument-error '+xfixed "'le or 'be" endian)) + (xfixed size signed endian fracbits)) + +(define (fixed-shift xf) + (arithmetic-shift 1 (xfixed-fracbits xf))) + +(define fixed16 (+xfixed 2)) +(define fixed16be (+xfixed 2 #:endian 'be)) +(define fixed16le (+xfixed 2 #:endian 'le)) +(define fixed32 (+xfixed 4)) +(define fixed32be (+xfixed 4 #:endian 'be)) +(define fixed32le (+xfixed 4 #:endian 'le)) + +(module+ test + (define bs (encode fixed16be 123.45)) + (check-equal? bs #"{s") + (check-equal? (ceiling (* (decode fixed16be bs) 100)) 12345.0))