1: ;;
    2: ;; test for tree-map
    3: ;;
    4: 
    5: (use gauche.test)
    6: (test-start "treemap")
    7: 
    8: ;; Basic stuff
    9: (let1 tree1 #f
   10:   (test* "make-tree-map" #t
   11:          (begin (set! tree1 (make-tree-map = <))
   12:                 (tree-map? tree1)))
   13:   (test* "tree-map-get" *test-error*
   14:          (tree-map-get #f 0 'foo))
   15:   (test* "tree-map-get" 'not-found
   16:          (tree-map-get tree1 0 'not-found))
   17:   (test* "tree-map-get" *test-error*
   18:          (tree-map-get tree1 0))
   19:   (test* "tree-map-put!" *test-error*
   20:          (tree-map-put! #f 0 'foo))
   21:   (test* "tree-map-put!" "0"
   22:          (begin (tree-map-put! tree1 0 "0")
   23:                 (tree-map-get tree1 0)))
   24:   (test* "tree-map-put!" '("0" "1")
   25:          (begin (tree-map-put! tree1 1 "1")
   26:                 (list (tree-map-get tree1 0)
   27:                       (tree-map-get tree1 1))))
   28:   (test* "tree-map-put!" 'bar
   29:          (begin (tree-map-put! tree1 2 'foo)
   30:                 (tree-map-put! tree1 2 'bar)
   31:                 (tree-map-get tree1 2)))
   32:   '(test* "tree-map-check" #t
   33:          (tree-map-check tree1))
   34:   (test* "tree-map-fold" '(2 bar 1 "1" 0 "0")
   35:          (tree-map-fold tree1 list* '()))
   36:   (test* "tree-map-fold-right" '(0 "0" 1 "1" 2 bar)
   37:          (tree-map-fold-right tree1 list* '()))
   38:   (test* "tree-map-delete! (exiting key)" '(#t not-found)
   39:          (let1 r (tree-map-delete! tree1 1)
   40:            (list r (tree-map-get tree1 1 'not-found))))
   41:   (test* "tree-map-delete! (non-existing key)" #f
   42:          (tree-map-delete! tree1 1))
   43:   (test* "tree-map-delete!" 'no-error
   44:          (begin (tree-map-delete! tree1 1)
   45:                 'no-error))
   46:   (test* "tree-map->alist" '()
   47:          (tree-map->alist (make-tree-map = <)))
   48:   (test* "tree-map->alist" '((0 . "0") (1 . "1") (2 . "2"))
   49:          (let1 tree (make-tree-map = <)
   50:            (for-each (lambda (p) (tree-map-put! tree (car p) (cdr p)))
   51:                      '((0 . "0") (1 . "1") (2 . "2")))
   52:            (tree-map->alist tree)))
   53:   (test* "alist->tree-map" '((0 . "0") (1 . "1") (2 . "2"))
   54:          (tree-map->alist
   55:           (alist->tree-map '((0 . "0") (1 . "1") (2 . "2")) = <)))
   56:   (test* "tree-map-empty?" #f
   57:          (tree-map-empty? tree1))
   58:   (test* "tree-map-empty?" #t
   59:          (tree-map-empty? (make-tree-map = <)))
   60:   (test* "tree-map-empty?" *test-error*
   61:          (tree-map-empty? 'wrong-arg))
   62:   (test* "tree-map-exists?" '(#t #f)
   63:          (let1 tree (make-tree-map = <)
   64:            (tree-map-put! tree 1 'foo)
   65:            (map (cut tree-map-exists? tree <>)
   66:                 '(1 2))))
   67:   (test* "tree-map-num-entries" '(0 1 0)
   68:          (let* ((t (make-tree-map = <))
   69:                 (a (tree-map-num-entries t))
   70:                 (b (begin (tree-map-put! t 7 7)
   71:                           (tree-map-num-entries t)))
   72:                 (c (begin (tree-map-delete! t 7)
   73:                           (tree-map-num-entries t))))
   74:            (list a b c)))
   75:   (test* "tree-map-push!" '(bar foo)
   76:          (let1 tree (make-tree-map = <)
   77:            (tree-map-push! tree 1 'foo)
   78:            (tree-map-push! tree 1 'bar)
   79:            (tree-map-get tree 1)))
   80:   (test* "tree-map-pop!" '(foo bar)
   81:          (let1 tree (alist->tree-map '((1 foo bar)) = <)
   82:            (let1 r (tree-map-pop! tree 1)
   83:              (list r (tree-map-pop! tree 1)))))
   84:   (test* "tree-map-update!" 2
   85:          (let1 tree (make-tree-map = <)
   86:            (tree-map-update! tree 1 (cut + 1 <>) 0)
   87:            (tree-map-update! tree 1 (cut + 1 <>) 0)
   88:            (tree-map-get tree 1)))
   89:   )
   90: 
   91: ;; Min, max, iterators
   92: (let ((empty (make-tree-map = <))
   93:       (tree2 (alist->tree-map '((1 . "1") (0 . "0") (2 . "2")) = <)))
   94: 
   95:   (test* "tree-map-min" '(0 . "0") (tree-map-min tree2))
   96:   (test* "tree-map-max" '(2 . "2") (tree-map-max tree2))
   97:   (test* "tree-map-min" *test-error* (tree-map-min 'wrong-arg))
   98:   (test* "tree-map-max" *test-error* (tree-map-max 'wrong-arg))
   99: 
  100:   (test* "tree-map-keys" '(0 1 2)
  101:          (tree-map-keys tree2))
  102: 
  103:   (test* "tree-map-values" '("0" "1" "2")
  104:          (tree-map-values tree2))
  105: 
  106:   (test* "tree-map-copy" #t
  107:          (let1 new (tree-map-copy tree2)
  108:            (%tree-map-check-consistency new)
  109:            (equal? (tree-map->alist tree2)
  110:                    (tree-map->alist new))))
  111: 
  112:   (test* "tree-map-pop-min!" '((0 . "0") (1 . "1"))
  113:          (let1 r (tree-map-pop-min! tree2)
  114:            (list r (tree-map-min tree2))))
  115: 
  116:   (test* "tree-map-pop-max!" '((2 . "2") (1 . "1"))
  117:          (let1 r (tree-map-pop-max! tree2)
  118:            (list r (tree-map-max tree2))))
  119:   )
  120: 
  121: ;; The following test sequence is carefully assembled so that
  122: ;; it goes through every path in the rbtree manipulation routine.
  123: ;; The "case" numbers corresponds to BALANCE_CASE/DELETE_CASE macros
  124: ;; in treemap.c.
  125: 
  126: (let1 tree (make-tree-map = <)
  127:   (define (i . args) (dolist (k args) (tree-map-put! tree k k)))
  128:   (define (d . args) (dolist (k args) (tree-map-delete! tree k)))
  129:   (define (c) (%tree-map-check-consistency tree))
  130:   
  131:   ;; Insertion
  132:   ;;  case 0. adding to an empty tree
  133:   ;;    B:0
  134:   (test* "insertion case 0" #t (begin (i 0) (c)))
  135: 
  136:   ;;  case 2. adding to a black parent.
  137:   ;;    B:0
  138:   ;;      R:1
  139:   (test* "insetrion case 2" #t (begin (i 1) (c)))
  140: 
  141:   ;;  case 3&1. adding to a red parent, while uncle is also red.
  142:   ;;        R:-2
  143:   ;;      B:-1
  144:   ;;    B:0
  145:   ;;      B:1
  146:   ;;        R:2
  147:   (test* "insertion case 3&1" #t (begin (i -1 -2 2) (c)))
  148: 
  149:   ;;  case 5b. adding to a red parent, while uncle is black.
  150:   ;;           new node is on the right side of parent,
  151:   ;;           while parent is the left side of grandparent.
  152:   ;;           this goes through rotate_left, then rotate_right.
  153:   ;;        R:-2 => -2
  154:   ;;      B:-1 => -1
  155:   ;;    B:0 => 0
  156:   ;;        R:1 => 1
  157:   ;;      B:1.5 => 1.5
  158:   ;;        R:2 => 2
  159:   (test* "insertion case 5b" #t (begin (i 1.5) (c)))
  160: 
  161:   ;;  case 5a. same as 3a except left and right is swapped.
  162:   ;;        R:-2 => -2
  163:   ;;      B:-1.5 => -1.5
  164:   ;;        R:-1 => -1
  165:   ;;    B:0 => 0
  166:   ;;        R:1 => 1
  167:   ;;      B:1.5 => 1.5
  168:   ;;        R:2 => 2
  169:   (test* "insertion case 5a" #t (begin (i -1.5) (c)))
  170: 
  171:   ;; Deletion.
  172:   ;;   case 1.  deleting the leaf red node.
  173:   ;;        R:-2 => -2
  174:   ;;      B:-1.5 => -1.5
  175:   ;;        R:-1 => -1
  176:   ;;    B:0 => 0
  177:   ;;        R:1 => 1
  178:   ;;      B:1.5 => 1.5
  179:   (test* "deletion case 1" #t (begin (d 2) (c)))
  180: 
  181:   ;;   prepare for next test
  182:   ;;          R:-3 => -3
  183:   ;;        B:-2 => -2
  184:   ;;      R:-1.5 => -1.5
  185:   ;;        B:-1 => -1
  186:   ;;    B:0 => 0
  187:   ;;        B:1 => 1
  188:   ;;      R:1.5 => 1.5
  189:   ;;        B:2 => 2
  190:   ;;          R:3 => 3
  191:   (i 2 3 -2 -3)
  192: 
  193:   ;;   case 8a.  deleting the leaf black node.
  194:   ;;             parent is red, sibling is black.
  195:   ;;          R:-3 => -3
  196:   ;;        B:-2 => -2
  197:   ;;      R:-1.5 => -1.5
  198:   ;;        B:-1 => -1
  199:   ;;    B:0 => 0
  200:   ;;        B:1.5 => 1.5
  201:   ;;      R:2 => 2
  202:   ;;        B:3 => 3
  203:   (test* "deletion case 8a" #t (begin (d 1) (c)))
  204: 
  205:   ;;   case 8b.  same, except left/right swapped
  206:   ;;        B:-3 => -3
  207:   ;;      R:-2 => -2
  208:   ;;        B:-1.5 => -1.5
  209:   ;;    B:0 => 0
  210:   ;;        B:1.5 => 1.5
  211:   ;;      R:2 => 2
  212:   ;;        B:3 => 3
  213:   (test* "deletion case8b" #t (begin (d -1) (c)))
  214: 
  215:   ;;   case 6.  deleting red node w/ both children
  216:   ;;            In our implementation, the node is first replaced by
  217:   ;;            its previous node until we get a single-child case,
  218:   ;;            then the balancing is applied.  In this particular case
  219:   ;;            it degenerates to the deletion of a black node whose
  220:   ;;            parent is red and whose sibling is black.
  221:   ;;        B:-3 => -3
  222:   ;;      R:-2 => -2
  223:   ;;        B:-1.5 => -1.5
  224:   ;;    B:0 => 0
  225:   ;;      B:1.5 => 1.5
  226:   ;;        R:3 => 3
  227:   (test* "deletion case6" #t (begin (d 2) (c)))
  228: 
  229:   ;;   case 2.  deleting black node, whose parent is black and sibing is red.
  230:   ;;        B:-3 => -3
  231:   ;;      R:-2 => -2
  232:   ;;        B:-1.5 => -1.5
  233:   ;;    B:0 => 0
  234:   ;;      B:3 => 3
  235:   (test* "deletion case2" #t (begin (d 1.5) (c)))
  236: 
  237:   ;; preparation
  238:   ;;        B:-3 => -3
  239:   ;;      B:-2 => -2
  240:   ;;        B:-1.5 => -1.5
  241:   ;;    B:0 => 0
  242:   ;;          R:0.5 => 0.5
  243:   ;;        B:1 => 1
  244:   ;;      B:2 => 2
  245:   ;;          B:2.5 => 2.5
  246:   ;;        R:3 => 3
  247:   ;;          B:3.5 => 3.5
  248:   ;;            R:4 => 4
  249:   (i 2 1 .5 2.5 3.5 4)
  250: 
  251:   ;;   case 5.  deleting black node, whose parent and sibling is black
  252:   ;;            and sibling's both child is black.
  253:   ;;        B:-2 => -2
  254:   ;;          R:-1.5 => -1.5
  255:   ;;      B:0 => 0
  256:   ;;          R:0.5 => 0.5
  257:   ;;        B:1 => 1
  258:   ;;    B:2 => 2
  259:   ;;        B:2.5 => 2.5
  260:   ;;      B:3 => 3
  261:   ;;        B:3.5 => 3.5
  262:   ;;          R:4 => 4
  263:   (test* "deletion case5" #t (begin (d -3) (c)))
  264: 
  265:   ;; preparation
  266:   ;;          B:-2 => -2
  267:   ;;        R:-1.5 => -1.5
  268:   ;;            R:-1 => -1
  269:   ;;          B:-0.5 => -0.5
  270:   ;;      B:0 => 0
  271:   ;;          R:0.5 => 0.5
  272:   ;;        B:1 => 1
  273:   ;;    B:2 => 2
  274:   ;;        B:2.5 => 2.5
  275:   ;;      B:3 => 3
  276:   ;;        B:3.5 => 3.5
  277:   ;;          R:4 => 4
  278:   (i -0.5 -1)
  279: 
  280:   ;;   case 7a  deleting black node, which is a left child of its parent,
  281:   ;;            and its sibling is black, and sibling's left child is red.
  282:   ;;            This goes through a nested if-statement in delete_node1()
  283:   ;;            and involves swapping sibling.
  284:   (test* "deletion case7a" #t (begin (d -2) (c)))
  285: 
  286:   ;;   case 4b.  deleting black node, whose sibling is red.
  287:   (test* "deletion case4b" #t (begin (d 0.5 1) (c)))
  288: 
  289:   ;;   case 3.  this goes through parent==NULL stop condition in the
  290:   ;;            loop in delete_node1.
  291:   ;;      B:-1.5 => -1.5
  292:   ;;        R:-0.5 => -0.5
  293:   ;;    B:0 => 0
  294:   ;;        B:2.5 => 2.5
  295:   ;;      R:3 => 3
  296:   ;;        B:3.5 => 3.5
  297:   ;;          R:4 => 4
  298:   (test* "deletion case3" #t (begin (d 2 -1) (c)))
  299: 
  300:   ;; preparation
  301:   ;;          R:-4 => -4
  302:   ;;        B:-3 => -3
  303:   ;;          R:-2 => -2
  304:   ;;      R:-1 => -1
  305:   ;;          R:-0.7 => -0.7
  306:   ;;        B:-0.5 => -0.5
  307:   ;;    B:0 => 0
  308:   ;;      B:2.5 => 2.5
  309:   ;;        R:4 => 4
  310:   (d 3.5 3 -1.5)
  311:   (i -1 -2 -3 -4 -0.7)
  312: 
  313:   ;; insertion case 4a.
  314:   ;;          R:-4 => -4
  315:   ;;        B:-3 => -3
  316:   ;;          R:-2 => -2
  317:   ;;      R:-1 => -1
  318:   ;;          R:-0.7 => -0.7
  319:   ;;        B:-0.6 => -0.6
  320:   ;;          R:-0.5 => -0.5
  321:   ;;    B:0 => 0
  322:   ;;      B:2.5 => 2.5
  323:   ;;        R:4 => 4
  324:   (test* "insertion case4a" #t (begin (i -0.6) (c)))
  325: 
  326:   ;; preparation
  327:   ;;      B:-2 => -2
  328:   ;;    B:-1 => -1
  329:   ;;        B:-0.7 => -0.7
  330:   ;;      R:-0.6 => -0.6
  331:   ;;          R:-0.5 => -0.5
  332:   ;;        B:0 => 0
  333:   (d 2.5 4 -3 -4)
  334: 
  335:   ;;   case 4a.  the reverse case of 4b.
  336:   ;;      B:-1 => -1
  337:   ;;        R:-0.7 => -0.7
  338:   ;;    B:-0.6 => -0.6
  339:   ;;        R:-0.5 => -0.5
  340:   ;;      B:0 => 0
  341:   (test* "deletion case4a" #t (begin (d -2) (c)))
  342: 
  343:   ;; preparation
  344:   ;;          R:-2 => -2
  345:   ;;      B:-1 => -1
  346:   ;;    B:-0.6 => -0.6
  347:   ;;        B:-0.5 => -0.5
  348:   ;;          R:-0.3 => -0.3
  349:   ;;      R:0 => 0
  350:   ;;          R:1 => 1
  351:   ;;        B:2 => 2
  352:   ;;          R:3 => 3
  353:   (d -0.7)
  354:   (i -2 2 1 3 -0.3)
  355: 
  356:   ;; insertion case 4b
  357:   ;;        R:-2 => -2
  358:   ;;      B:-1 => -1
  359:   ;;    B:-0.6 => -0.6
  360:   ;;          R:-0.5 => -0.5
  361:   ;;        B:-0.4 => -0.4
  362:   ;;          R:-0.3 => -0.3
  363:   ;;      R:0 => 0
  364:   ;;          R:1 => 1
  365:   ;;        B:2 => 2
  366:   ;;          R:3 => 3
  367:   (test* "insertion case4b" #t (begin (i -0.4) (c)))
  368:   )
  369:   
  370: 
  371: (test-end)
  372: