-
Notifications
You must be signed in to change notification settings - Fork 4
/
convert.ss
114 lines (93 loc) · 3.98 KB
/
convert.ss
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
#lang scheme/base
(require "base.ss")
(require (only-in srfi/13 string-pad string-drop string-take))
; number -> symbol
(define (number->symbol num)
(string->symbol (number->string num)))
; symbol -> number
(define (symbol->number sym)
(string->number (symbol->string sym)))
; (U number #f) -> (U string #f)
(define (number+false->string+false num)
(and num (number->string num)))
; (U string #f) -> (U number #f)
(define (string+false->number+false str)
(and str (string->number str)))
; (U symbol #f) -> (U string #f)
(define (symbol+false->string+false num)
(and num (symbol->string num)))
; (U string #f) -> (U symbol #f)
(define (string+false->symbol+false sym)
(and sym (string->symbol sym)))
; (U number #f) -> (U symbol #f)
(define (number+false->symbol+false num)
(and num (number->symbol num)))
; (U symbol #f) -> (U number #f)
(define (symbol+false->number+false sym)
(and sym (symbol->number sym)))
; Hexadecimal ------------------------------------
; natural [#:uppercase? boolean] [#:digits (U natural #f)] [#:prefix? boolean] -> string
(define (natural->hex-string num #:uppercase? [uppercase? #f] #:digits [digits 1] #:prefix? [prefix? #f])
(define (make-digit num)
(case num
[( 0) #\0] [( 1) #\1] [( 2) #\2] [( 3) #\3]
[( 4) #\4] [( 5) #\5] [( 6) #\6] [( 7) #\7]
[( 8) #\8] [( 9) #\9] [(10) #\a] [(11) #\b]
[(12) #\c] [(13) #\d] [(14) #\e] [(15) #\f]))
(define (make-digits num)
(if (zero? num)
null
(cons (make-digit (remainder num 16))
(make-digits (quotient num 16)))))
(let* ([ans0 (apply string (reverse (make-digits num)))]
; Pad with extra zeroes:
[ans1 (if (and digits (< (string-length ans0) digits))
(string-pad ans0 digits #\0)
ans0)]
; Do case conversion:
[ans2 (if uppercase?
(string-upcase ans1)
ans1)]
; Add "0x" prefix:
[ans3 (if prefix?
(string-append "0x" ans2)
ans2)])
ans3))
; string [#:prefix? boolean] -> natural
(define (hex-string->natural str #:prefix? [prefix? #f])
(define (type-error)
(if prefix?
(raise-type-error 'hex-string->natural "hex string with \"0x\" prefix" str)
(raise-type-error 'hex-string->natural "hex string" str)))
(define (parse-digit chr)
(case chr
[(#\0) 0] [(#\1) 1] [(#\2) 2] [(#\3) 3]
[(#\4) 4] [(#\5) 5] [(#\6) 6] [(#\7) 7]
[(#\8) 8] [(#\9) 9] [(#\a) 10] [(#\b) 11]
[(#\c) 12] [(#\d) 13] [(#\e) 14] [(#\f) 15]
[else (raise-type-error 'hex-string->natural "hex string" str)]))
(let ([str (if prefix?
(if (regexp-match #rx"^0x" str)
(string-drop str 2)
(type-error))
(if (zero? (string-length str))
(type-error)
str))])
(let loop ([digits (reverse (map parse-digit (string->list (string-downcase str))))] [exponent 1] [accum 0])
(if (null? digits)
accum
(loop (cdr digits)
(* exponent 16)
(+ accum (* (car digits) exponent)))))))
; Provide statements -----------------------------
(provide/contract
[number->symbol (-> number? symbol?)]
[symbol->number (-> symbol? (or/c number? #f))]
[number+false->string+false (-> (or/c number? #f) (or/c string? #f))]
[string+false->number+false (-> (or/c string? #f) (or/c number? #f))]
[symbol+false->string+false (-> (or/c symbol? #f) (or/c string? #f))]
[string+false->symbol+false (-> (or/c string? #f) (or/c symbol? #f))]
[number+false->symbol+false (-> (or/c number? #f) (or/c symbol? #f))]
[symbol+false->number+false (-> (or/c symbol? #f) (or/c number? #f))]
[natural->hex-string (->* (natural-number/c) (#:uppercase? boolean? #:digits (or/c natural-number/c #f) #:prefix? boolean?) string?)]
[hex-string->natural (->* (string?) (#:prefix? boolean?) natural-number/c)])