fork download
copy 
  1. ; base conversion
  2.  
  3. (define-syntax list-match
  4.   (syntax-rules ()
  5.     ((_ expr (pattern fender ... template) ...)
  6.       (let ((obj expr))
  7.         (cond ((list-match-aux obj pattern fender ...
  8.                 (list template)) => car) ...
  9.               (else (error 'list-match "pattern failure")))))))
  10.  
  11. (define-syntax list-match-aux
  12.   (lambda (stx)
  13.     (define (underscore? x)
  14.       (and (identifier? x) (free-identifier=? x (syntax _))))
  15.     (syntax-case stx (quote quasiquote)
  16.       ((_ obj pattern template)
  17.         (syntax (list-match-aux obj pattern #t template)))
  18.       ((_ obj () fender template)
  19.         (syntax (and (null? obj) fender template)))
  20.       ((_ obj underscore fender template)
  21.         (underscore? (syntax underscore))
  22.         (syntax (and fender template)))
  23.       ((_ obj var fender template)
  24.         (identifier? (syntax var))
  25.         (syntax (let ((var obj)) (and fender template))))
  26.       ((_ obj (quote datum) fender template)
  27.         (syntax (and (equal? obj (quote datum)) fender template)))
  28.       ((_ obj (quasiquote datum) fender template)
  29.         (syntax (and (equal? obj (quasiquote datum)) fender template)))
  30.       ((_ obj (kar . kdr) fender template)
  31.         (syntax (and (pair? obj)
  32.                 (let ((kar-obj (car obj)) (kdr-obj (cdr obj)))
  33.                   (list-match-aux kar-obj kar
  34.                         (list-match-aux kdr-obj kdr fender template))))))
  35.       ((_ obj const fender template)
  36.         (syntax (and (equal? obj const) fender template))))))
  37.  
  38. (define (2to4 str)
  39.   (let loop ((bits (reverse (string->list str))) (quads (list)))
  40.     (cond ((null? bits)
  41.             (list->string quads))
  42.           ((null? (cdr bits))
  43.             (loop (cdr bits) (cons (car bits) quads)))
  44.           ((and (char=? (cadr bits) #\0) (char=? (car bits) #\0))
  45.             (loop (cddr bits) (cons #\0 quads)))
  46.           ((and (char=? (cadr bits) #\0) (char=? (car bits) #\1))
  47.             (loop (cddr bits) (cons #\1 quads)))
  48.           ((and (char=? (cadr bits) #\1) (char=? (car bits) #\0))
  49.             (loop (cddr bits) (cons #\2 quads)))
  50.           ((and (char=? (cadr bits) #\1) (char=? (car bits) #\1))
  51.             (loop (cddr bits) (cons #\3 quads)))
  52.           (else (error '2to4 "can't happen")))))
  53.  
  54. (display (2to4 "11011000")) (newline)
  55.  
  56. (define (2to4 str)
  57.   (let loop ((bits (reverse (string->list str))) (quads (list)))
  58.     (list-match bits
  59.       (() (list->string quads))
  60.       ((b) (loop '() (cons b quads)))
  61.       ((#\0 #\0 . bs) (loop bs (cons #\0 quads)))
  62.       ((#\1 #\0 . bs) (loop bs (cons #\1 quads)))
  63.       ((#\0 #\1 . bs) (loop bs (cons #\2 quads)))
  64.       ((#\1 #\1 . bs) (loop bs (cons #\3 quads)))
  65.       (else (error '2to4 "can't happen")))))
  66.  
  67. (display (2to4 "11011000")) (newline)
  68.  
  69. (define (2to4 str)
  70.   (number->string (string->number str 2) 4))
  71.  
  72. (display (2to4 "11011000")) (newline)
  73.  
  74. (define (convert in out str)
  75.   (number->string (string->number str in) out))
  76.  
  77. (display (convert 2 4 "11011000")) (newline)
Success #stdin #stdout 0.03s 43600KB
comments (?)
stdin
copy 
Standard input is empty
stdout
copy 
3120
3120
3120
3120
https://ideone.com/qtTD4h
language:
Scheme (guile 2.2.4)
created:
7 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!