Welcome to the CHICKEN Scheme pasting service

nested callable data structures pasted by mario-goulart on Sat Dec 7 15:37:16 2013

(use callable-hash-tables)

(define +none+
  (list 'none))

(define (nested-get callable path #!optional default)
  (let loop ((path path)
             (callable/val callable))
    (if (null? path)
        (if (eq? callable/val +none+)
            default
            callable/val)
        (if (procedure? callable/val)
            (let* ((key (car path))
                   (val (callable/val key +none+)))
              (if (eq? val +none+)
                  default
                  (loop (cdr path) val)))
            default))))

(define ~make-callable-hash-table)

(define silly-list
  (~(car . 0)
       (cdr . ,(~(car . 1)
                    (cdr . ,(~(car . 2)
                                 (cdr))))))))))

(print (nested-get silly-list '(cdr cdr car)))
[ permalink | raw ]

fixed nested callable data structures pasted by mario-goulart on Sat Dec 7 15:40:49 2013

(use callable-hash-tables)

(define +none+
  (list 'none))

(define (nested-get callable path #!optional default)
  (let loop ((path path)
             (callable/val callable))
    (if (null? path)
        (if (eq? callable/val +none+)
            default
            callable/val)
        (if (procedure? callable/val)
            (let* ((key (car path))
                   (val (callable/val key +none+)))
              (if (eq? val +none+)
                  default
                  (loop (cdr path) val)))
            default))))

(define ^ make-callable-hash-table)

(define silly-list
  (^ `((car . 0)
       (cdr . ,(^ `((car . 1)
                    (cdr . ,(^ `((car . 2)
                                 (cdr))))))))))

(print (nested-get silly-list '(cdr cdr car)))
[ permalink | raw ]

get-in & set-in! pasted by mario-goulart on Sat Dec 7 19:33:58 2013

(use callable-hash-tables)

(define +none+
  (list 'none))

(define (get-in callable path #!optional default)
  (let loop ((path path)
             (node callable))
    (if (null? path)
        (if (eq? node +none+)
            default
            node)
        (if (procedure? node)
            (let* ((key (car path))
                   (val (node key +none+)))
              (if (eq? val +none+)
                  default
                  (loop (cdr path) val)))
            default))))

(define (new-callable callable)
  ((case (procedure-information callable)
     ((callable-alist) make-callable-alist)
     ((callable-hash-table) make-callable-hash-table)
     (else (error 'set-in!
                  "Invalid callable datastructure type:"
                  (procedure-information callable))))))

(define (callable-mapping-data-structure? obj required-type)
  (and (procedure? obj)
       ((case required-type
          ((callable-alist) callable-alist?)
          ((callable-hash-table) callable-hash-table?)
          (else (error 'set-in!
                       "Invalid callable datastructure type:"
                       required-type)))
        obj)))

(define (set-in! callable path value)
  (let loop ((path path)
             (node callable))
    (if (null? (cdr path))
        ;; Reached the last item in path, so set it and return it
        (begin
          (set! (node (car path)) value)
          node)
        ;; Not the last item in path. If the current path doesn't
        ;; exist, create it.  If it exists but it is not a callable,
        ;; set it to a new callable. Otherwise, just leave it as it is.
        (let* ((key (car path))
               (val (node key +none+)))
          (when (or (eq? val +none+)
                    (not (callable-mapping-data-structure?
                          val
                          (procedure-information node))))
            (set! (node key)
                  (new-callable node)))
          (loop (cdr path)
                (node key))))))

(define ^ make-callable-hash-table)

(define silly-list
  (^ `((car . 0)
       (cdr . ,(^ `((car . 1)
                    (cdr . ,(^ `((car . 2)
                                 (cdr))))))))))

(use test)

(test-assert (callable-hash-table? (get-in silly-list '())))

(test "checking car = 0"
      0
      (get-in silly-list '(car)))

(test "checking cadr = 1"
      1
      (get-in silly-list '(cdr car)))

(test "checking caddr = 2"
      2
      (get-in silly-list '(cdr cdr car)))

(test "setting car to a"
      'a
      (get-in (set-in! silly-list '(car) 'a) '(car)))

(test "setting cadr to b"
      '(a b)
      (begin
        (set-in! silly-list '(cdr car) 'b)
        (list (get-in silly-list '(car))
              (get-in silly-list '(cdr car)))))

(test "setting caddr to c"
      '(a b c)
      (begin
        (set-in! silly-list '(cdr cdr car) 'c)
        (list (get-in silly-list '(car))
              (get-in silly-list '(cdr car))
              (get-in silly-list '(cdr cdr car)))))

(test "setting cadddr (non existent up til now) to d"
      '(a b c d)
      (begin
        (set-in! silly-list '(cdr cdr cdr car) 'd)
        (list (get-in silly-list '(car))
              (get-in silly-list '(cdr car))
              (get-in silly-list '(cdr cdr car))
              (get-in silly-list '(cdr cdr cdr car)))))

(test "setting caddr to x"
      '(a b x d)
      (begin
        (set-in! silly-list '(cdr cdr car) 'x)
        (list (get-in silly-list '(car))
              (get-in silly-list '(cdr car))
              (get-in silly-list '(cdr cdr car))
              (get-in silly-list '(cdr cdr cdr car)))))

(define something (^))
(set-in! something '(foo) 'a)
(test 'a (something 'foo))
(test 'a (get-in something '(foo)))

(set-in! something '(foo bar) 'b)
(test 'b (get-in something '(foo bar)))

(set-in! something '(foo bar baz) (^ '((foo . 1) (bar . 2))))
(test-assert (callable-hash-table? (get-in something '(foo))))
(test-assert (callable-hash-table? (get-in something '(foo bar))))
(test-assert (callable-hash-table? (get-in something '(foo bar baz))))
(test 1 (get-in something '(foo bar baz foo)))
(test 2 (get-in something '(foo bar baz bar)))
[ permalink | raw ]

get-in & set-in! (bugfix!) added by mario-goulart on Sat Dec 7 19:39:42 2013

(use callable-hash-tables)

(define +none+
  (list 'none))

(define (get-in callable path #!optional default)
  (let loop ((path path)
             (node callable))
    (if (null? path)
        (if (eq? node +none+)
            default
            node)
        (if (procedure? node)
            (let* ((key (car path))
                   (val (node key +none+)))
              (if (eq? val +none+)
                  default
                  (loop (cdr path) val)))
            default))))

(define (new-callable callable)
  ((case (procedure-information callable)
     ((callable-alist) make-callable-alist)
     ((callable-hash-table) make-callable-hash-table)
     (else (error 'set-in!
                  "Invalid callable datastructure type:"
                  (procedure-information callable))))))

(define (callable-mapping-data-structure? obj required-type)
  (and (procedure? obj)
       ((case required-type
          ((callable-alist) callable-alist?)
          ((callable-hash-table) callable-hash-table?)
          (else (error 'set-in!
                       "Invalid callable datastructure type:"
                       required-type)))
        obj)))

(define (set-in! callable path value)
  (if (null? path)
      callable
      (let loop ((path path)
                 (node callable))
        (if (null? (cdr path))
            ;; Reached the last item in path, so set it and return it
            (begin
              (set! (node (car path)) value)
              node)
            ;; Not the last item in path. If the current path doesn't
            ;; exist, create it.  If it exists but it is not a callable,
            ;; set it to a new callable. Otherwise, just leave it as it is.
            (let* ((key (car path))
                   (val (node key +none+)))
              (when (or (eq? val +none+)
                        (not (callable-mapping-data-structure?
                              val
                              (procedure-information node))))
                (set! (node key)
                      (new-callable node)))
              (loop (cdr path)
                    (node key)))))))

(define ^ make-callable-hash-table)

(define silly-list
  (^ `((car . 0)
       (cdr . ,(^ `((car . 1)
                    (cdr . ,(^ `((car . 2)
                                 (cdr))))))))))

(use test)

(test-assert (callable-hash-table? (get-in silly-list '())))

(test "checking car = 0"
      0
      (get-in silly-list '(car)))

(test "checking cadr = 1"
      1
      (get-in silly-list '(cdr car)))

(test "checking caddr = 2"
      2
      (get-in silly-list '(cdr cdr car)))

(test "setting car to a"
      'a
      (get-in (set-in! silly-list '(car) 'a) '(car)))

(test "setting cadr to b"
      '(a b)
      (begin
        (set-in! silly-list '(cdr car) 'b)
        (list (get-in silly-list '(car))
              (get-in silly-list '(cdr car)))))

(test "setting caddr to c"
      '(a b c)
      (begin
        (set-in! silly-list '(cdr cdr car) 'c)
        (list (get-in silly-list '(car))
              (get-in silly-list '(cdr car))
              (get-in silly-list '(cdr cdr car)))))

(test "setting cadddr (non existent up til now) to d"
      '(a b c d)
      (begin
        (set-in! silly-list '(cdr cdr cdr car) 'd)
        (list (get-in silly-list '(car))
              (get-in silly-list '(cdr car))
              (get-in silly-list '(cdr cdr car))
              (get-in silly-list '(cdr cdr cdr car)))))

(test "setting caddr to x"
      '(a b x d)
      (begin
        (set-in! silly-list '(cdr cdr car) 'x)
        (list (get-in silly-list '(car))
              (get-in silly-list '(cdr car))
              (get-in silly-list '(cdr cdr car))
              (get-in silly-list '(cdr cdr cdr car)))))

(define something (^))
(set-in! something '(foo) 'a)
(test 'a (something 'foo))
(test 'a (get-in something '(foo)))

(set-in! something '(foo bar) 'b)
(test 'b (get-in something '(foo bar)))

(set-in! something '(foo bar baz) (^ '((foo . 1) (bar . 2))))
(test-assert (callable-hash-table? (get-in something '(foo))))
(test-assert (callable-hash-table? (get-in something '(foo bar))))
(test-assert (callable-hash-table? (get-in something '(foo bar baz))))
(test 1 (get-in something '(foo bar baz foo)))
(test 2 (get-in something '(foo bar baz bar)))
[ permalink | raw ]

Your annotation:

Enter a new annotation:

Your nick:
The title of your paste:
Your paste (mandatory) :
What module provides regular expressions support?
Visually impaired? Let me spell it for you (wav file) download WAV