test-suite/tests/vlist.test

   1 ;;;; vlist.test --- VLists.       -*- mode: scheme; coding: utf-8; -*-
   2 ;;;;
   3 ;;;; Ludovic Courtès <ludo@gnu.org>
   4 ;;;;
   5 ;;;;    Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
   6 ;;;;
   7 ;;;; This library is free software; you can redistribute it and/or
   8 ;;;; modify it under the terms of the GNU Lesser General Public
   9 ;;;; License as published by the Free Software Foundation; either
  10 ;;;; version 3 of the License, or (at your option) any later version.
  11 ;;;;
  12 ;;;; This library is distributed in the hope that it will be useful,
  13 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15 ;;;; Lesser General Public License for more details.
  16 ;;;;
  17 ;;;; You should have received a copy of the GNU Lesser General Public
  18 ;;;; License along with this library; if not, write to the Free Software
  19 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  20
  21 (define-module (test-vlist)
  22   #:use-module (test-suite lib)
  23   #:use-module (ice-9 vlist)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (srfi srfi-26))
  26
  27 \f
  28 ;;;
  29 ;;; VLists.
  30 ;;;
  31
  32 (with-test-prefix "vlist"
  33
  34   (pass-if "vlist?"
  35     (and (vlist? vlist-null)
  36          (vlist? (vlist-cons 'a vlist-null))))
  37
  38   (pass-if "vlist-null?"
  39     (vlist-null? vlist-null))
  40
  41   (pass-if "vlist-cons"
  42     (let* ((v1 (vlist-cons 1 vlist-null))
  43            (v2 (vlist-cons 2 v1))
  44            (v3 (vlist-cons 3 v2))
  45            (v4 (vlist-cons 4 v3)))
  46       (every vlist? (list v1 v2 v3 v4))))
  47
  48   (pass-if "vlist-head"
  49     (let* ((v1 (vlist-cons 1 vlist-null))
  50            (v2 (vlist-cons 2 v1))
  51            (v3 (vlist-cons 3 v2))
  52            (v4 (vlist-cons 4 v3)))
  53       (equal? (map vlist-head (list v1 v2 v3 v4))
  54               '(1 2 3 4))))
  55
  56   (pass-if "vlist-tail"
  57     (let* ((v1 (vlist-cons 1 vlist-null))
  58            (v2 (vlist-cons 2 v1))
  59            (v3 (vlist-cons 3 v2))
  60            (v4 (vlist-cons 4 v3)))
  61       (equal? (map vlist-head
  62                    (map vlist-tail (list v2 v3 v4)))
  63               '(1 2 3))))
  64
  65   (pass-if "vlist->list"
  66     (let* ((v1 (vlist-cons 1 vlist-null))
  67            (v2 (vlist-cons 2 v1))
  68            (v3 (vlist-cons 3 v2))
  69            (v4 (vlist-cons 4 v3)))
  70       (equal? '(4 3 2 1)
  71               (vlist->list v4))))
  72
  73   (pass-if "list->vlist"
  74     (equal? (vlist->list (list->vlist '(1 2 3 4 5)))
  75             '(1 2 3 4 5)))
  76
  77   (pass-if "vlist-drop"
  78     (equal? (vlist->list (vlist-drop (list->vlist (iota 77)) 7))
  79             (drop (iota 77) 7)))
  80
  81   (pass-if "vlist-cons2"
  82     ;; Example from Bagwell's paper, Figure 2.
  83     (let* ((top  (list->vlist '(8 7 6 5 4 3)))
  84            (part (vlist-tail (vlist-tail top)))
  85            (test (vlist-cons 9 part)))
  86       (equal? (vlist->list test)
  87               '(9 6 5 4 3))))
  88
  89   (pass-if "vlist-cons3"
  90     (let ((vlst (vlist-cons 'a
  91                             (vlist-cons 'b
  92                                         (vlist-drop (list->vlist (iota 5))
  93                                                     3)))))
  94       (equal? (vlist->list vlst)
  95               '(a b 3 4))))
  96
  97   (pass-if "vlist-map"
  98     (equal? (vlist->list (vlist-map 1+ (list->vlist '(1 2 3 4 5))))
  99             '(2 3 4 5 6)))
 100
 101   (pass-if "vlist-length"
 102     (= (vlist-length (list->vlist (iota 77)))
 103        77))
 104
 105   (pass-if "vlist-length complex"
 106     (= (vlist-length (fold vlist-cons
 107                            (vlist-drop (list->vlist (iota 77)) 33)
 108                            (iota (- 33 7))))
 109        70))
 110
 111   (pass-if "vlist-ref"
 112     (let* ((indices (iota 111))
 113            (vlst    (list->vlist indices)))
 114       (equal? (map (lambda (i)
 115                      (vlist-ref vlst i))
 116                    indices)
 117               indices)))
 118
 119   (pass-if "vlist-ref degenerate"
 120     ;; Degenerate case where VLST contains only 1-element blocks.
 121     (let* ((indices (iota 111))
 122            (vlst    (fold (lambda (i vl)
 123                             (let ((vl (vlist-cons 'x vl)))
 124                               (vlist-cons i (vlist-tail vl))))
 125                           vlist-null
 126                           indices)))
 127       (equal? (map (lambda (i)
 128                      (vlist-ref vlst i))
 129                    (reverse indices))
 130               indices)))
 131
 132   (pass-if "vlist-filter"
 133     (let* ((lst  (iota 33))
 134            (vlst (fold-right vlist-cons vlist-null lst)))
 135       (equal? (vlist->list (vlist-filter even? vlst))
 136               (filter even? lst))))
 137
 138   (pass-if "vlist-delete"
 139     (let* ((lst  '(a b c d e))
 140            (vlst (fold-right vlist-cons vlist-null lst)))
 141       (equal? (vlist->list (vlist-delete 'c vlst))
 142               (delete 'c lst))))
 143
 144   (pass-if "vlist-take"
 145     (let* ((lst  (iota 77))
 146            (vlst (fold-right vlist-cons vlist-null lst)))
 147       (equal? (vlist->list (vlist-take vlst 44))
 148               (take lst 44))))
 149
 150   (pass-if "vlist-unfold"
 151     (let ((results (map (lambda (unfold)
 152                           (unfold (lambda (i) (> i 100))
 153                                   (lambda (i) i)
 154                                   (lambda (i) (+ i 1))
 155                                   0))
 156                         (list unfold vlist-unfold))))
 157       (equal? (car results)
 158               (vlist->list (cadr results)))))
 159
 160   (pass-if "vlist-append"
 161     (let* ((lists '((a) (b c) (d e f) (g)))
 162            (vlst  (apply vlist-append (map list->vlist lists)))
 163            (lst   (apply append lists)))
 164       (equal? lst (vlist->list vlst)))))
 165
 166 \f
 167 ;;;
 168 ;;; VHash.
 169 ;;;
 170
 171 (with-test-prefix "vhash"
 172
 173   (pass-if "vhash?"
 174     (vhash? (vhash-cons "hello" "world" vlist-null)))
 175
 176   (pass-if "vhash-assoc vlist-null"
 177     (not (vhash-assq 'a vlist-null)))
 178
 179   (pass-if "vhash-assoc simple"
 180     (let ((vh (vhash-cons "hello" "world" vlist-null)))
 181       (equal? (cons "hello" "world")
 182               (vhash-assoc "hello" vh))))
 183
 184   (pass-if "vhash-assoc regular"
 185     (let* ((keys   '(a b c d e f g h i))
 186            (values '(1 2 3 4 5 6 7 8 9))
 187            (vh     (fold vhash-cons vlist-null keys values)))
 188       (fold (lambda (k v result)
 189               (and result
 190                    (equal? (cons k v)
 191                            (vhash-assoc k vh eq?))))
 192             #t
 193             keys
 194             values)))
 195
 196   (pass-if "vhash-assoc tail"
 197     (let* ((keys   '(a b c d e f g h i))
 198            (values '(1 2 3 4 5 6 7 8 9))
 199            (vh1    (fold vhash-consq vlist-null keys values))
 200            (vh2    (vhash-consq 'x 'x (vlist-tail vh1))))
 201       (and (fold (lambda (k v result)
 202                    (and result
 203                         (equal? (cons k v)
 204                                 (vhash-assq k vh2))))
 205                  #t
 206                  (cons 'x (delq 'i keys))
 207                  (cons 'x (delv 9 values)))
 208            (not (vhash-assq 'i  vh2)))))
 209
 210   (pass-if "vhash-assoc degenerate"
 211     (let* ((keys   '(a b c d e f g h i))
 212            (values '(1 2 3 4 5 6 7 8 9))
 213            (vh     (fold (lambda (k v vh)
 214                            ;; Degenerate case where VH2 contains only
 215                            ;; 1-element blocks.
 216                            (let* ((vh1 (vhash-cons 'x 'x vh))
 217                                   (vh2 (vlist-tail vh1)))
 218                              (vhash-cons k v vh2)))
 219                          vlist-null keys values)))
 220       (and (fold (lambda (k v result)
 221                    (and result
 222                         (equal? (cons k v)
 223                                 (vhash-assoc k vh))))
 224                  #t
 225                  keys
 226                  values)
 227            (not (vhash-assoc 'x vh)))))
 228
 229   (pass-if "vhash as vlist"
 230     (let* ((keys   '(a b c d e f g h i))
 231            (values '(1 2 3 4 5 6 7 8 9))
 232            (vh     (fold vhash-cons vlist-null keys values))
 233            (alist  (fold alist-cons '() keys values)))
 234       (and (equal? (vlist->list vh) alist)
 235            (= (length alist) (vlist-length vh))
 236            (fold (lambda (i result)
 237                    (and result
 238                         (equal? (list-ref alist i)
 239                                 (vlist-ref vh i))))
 240                  #t
 241                  (iota (vlist-length vh))))))
 242
 243   (pass-if "vhash entry shadowed"
 244     (let* ((a (vhash-consq 'a 1 vlist-null))
 245            (b (vhash-consq 'a 2 a)))
 246       (and (= 1 (cdr (vhash-assq 'a a)))
 247            (= 2 (cdr (vhash-assq 'a b)))
 248            (= 1 (cdr (vhash-assq 'a (vlist-tail b)))))))
 249
 250   (pass-if "vlist-filter"
 251     (let* ((keys   '(a b c d e f g h i))
 252            (values '(1 2 3 4 5 6 7 8 9))
 253            (vh     (fold vhash-cons vlist-null keys values))
 254            (alist  (fold alist-cons '() keys values))
 255            (pred   (lambda (k+v)
 256                      (case (car k+v)
 257                        ((c f) #f)
 258                        (else  #t)))))
 259       (let ((vh    (vlist-filter pred vh))
 260             (alist (filter pred alist)))
 261         (and (equal? (vlist->list vh) alist)
 262              (= (length alist) (vlist-length vh))
 263              (fold (lambda (i result)
 264                      (and result
 265                           (equal? (list-ref alist i)
 266                                   (vlist-ref vh i))))
 267                    #t
 268                    (iota (vlist-length vh)))))))
 269
 270   (pass-if "vhash-delete"
 271     (let* ((keys   '(a b c d e f g d h i))
 272            (values '(1 2 3 4 5 6 7 0 8 9))
 273            (vh     (fold vhash-cons vlist-null keys values))
 274            (alist  (fold alist-cons '() keys values)))
 275       (let ((vh    (vhash-delete 'd vh))
 276             (alist (alist-delete 'd alist)))
 277         (and (= (length alist) (vlist-length vh))
 278              (fold (lambda (k result)
 279                      (and result
 280                           (equal? (assq k alist)
 281                                   (vhash-assoc k vh eq?))))
 282                    #t
 283                    keys)))))
 284
 285   (pass-if "vhash-delete honors HASH"
 286     ;; In 2.0.0, `vhash-delete' would construct a new vhash without
 287     ;; using the supplied hash procedure, which could lead to
 288     ;; inconsistencies.
 289     (let* ((s  "hello")
 290            (vh (fold vhash-consv
 291                      (vhash-consv s "world" vlist-null)
 292                      (iota 300)
 293                      (iota 300))))
 294       (and (vhash-assv s vh)
 295            (pair? (vhash-assv s (vhash-delete 123 vh eqv? hashv))))))
 296
 297   (pass-if "vhash-fold"
 298     (let* ((keys   '(a b c d e f g d h i))
 299            (values '(1 2 3 4 5 6 7 0 8 9))
 300            (vh     (fold vhash-cons vlist-null keys values))
 301            (alist  (fold alist-cons '() keys values)))
 302       (equal? alist (reverse (vhash-fold alist-cons '() vh)))))
 303
 304   (pass-if "vhash-fold-right"
 305     (let* ((keys   '(a b c d e f g d h i))
 306            (values '(1 2 3 4 5 6 7 0 8 9))
 307            (vh     (fold vhash-cons vlist-null keys values))
 308            (alist  (fold alist-cons '() keys values)))
 309       (equal? alist (vhash-fold-right alist-cons '() vh))))
 310
 311   (pass-if "alist->vhash"
 312     (let* ((keys   '(a b c d e f g d h i))
 313            (values '(1 2 3 4 5 6 7 0 8 9))
 314            (alist  (fold alist-cons '() keys values))
 315            (vh     (alist->vhash alist))
 316            (alist2 (vlist-fold cons '() vh)))
 317       (and (equal? alist (reverse alist2))
 318            (fold (lambda (k result)
 319                    (and result
 320                         (equal? (assq k alist)
 321                                 (vhash-assoc k vh eq?))))
 322                  #t
 323                  keys))))
 324
 325   (pass-if "vhash-fold*"
 326     (let* ((keys   (make-list 10 'a))
 327            (values (iota 10))
 328            (vh     (fold vhash-cons vlist-null keys values)))
 329       (equal? (vhash-fold* cons '() 'a vh)
 330               values)))
 331
 332   (pass-if "vhash-fold* tail"
 333     (let* ((keys   (make-list 100 'a))
 334            (values (iota 100))
 335            (vh     (fold vhash-cons vlist-null keys values)))
 336       (equal? (vhash-fold* cons '() 'a (vlist-drop vh 42))
 337               (take values (- 100 42)))))
 338
 339   (pass-if "vhash-fold* interleaved"
 340     (let* ((keys   '(a b a b a b a b a b c d e a b))
 341            (values '(1 0 2 0 3 0 4 0 5 0 0 0 0 6 0))
 342            (vh     (fold vhash-cons vlist-null keys values)))
 343       (equal? (vhash-fold* cons '() 'a vh)
 344               (filter (cut > <> 0) values))))
 345
 346   (pass-if "vhash-foldq* degenerate"
 347     (let* ((keys   '(a b a b a a a b a b a a a z))
 348            (values '(1 0 2 0 3 4 5 0 6 0 7 8 9 0))
 349            (vh     (fold (lambda (k v vh)
 350                            ;; Degenerate case where VH2 contains only
 351                            ;; 1-element blocks.
 352                            (let* ((vh1 (vhash-consq 'x 'x vh))
 353                                   (vh2 (vlist-tail vh1)))
 354                              (vhash-consq k v vh2)))
 355                          vlist-null keys values)))
 356       (equal? (vhash-foldq* cons '() 'a vh)
 357               (filter (cut > <> 0) values)))))