/pliant/language/type/set/old_index.pli
 
 1  # Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx 
 2  # 
 3  # This program is free software; you can redistribute it and/or 
 4  # modify it under the terms of the GNU General Public License version 2 
 5  # as published by the Free Software Foundation. 
 6  # 
 7  # This program is distributed in the hope that it will be useful, 
 8  # but WITHOUT ANY WARRANTY; without even the implied warranty of 
 9  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the 
 10  # GNU General Public License for more details. 
 11  # 
 12  # You should have received a copy of the GNU General Public License 
 13  # version 2 along with this program; if not, write to the Free Software 
 14  # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA. 
 15   
 16  scope "/pliant/language/" "/pliant/install/" 
 17  module "/pliant/install/ring3.pli" 
 18   
 19   
 20  module "/pliant/language/declare/internals.pli" 
 21  module "/pliant/language/basic/shunt.pli" 
 22  module "/pliant/language/debug/error1.pli" 
 23  module "/pliant/language/basic/shortcut.pli" 
 24  module "/pliant/language/basic/compare.pli" 
 25  module "/pliant/language/type/number/int.pli" 
 26  module "/pliant/language/type/text/str.pli" 
 27   
 28   
 29 
 
 30  #   data types 
 31   
 32   
 33  type IndexNode 
 34    field Arrow data 
 35    field Str key 
 36    field Pointer:IndexNode right left 
 37    field Pointer:IndexNode father 
 38    field Int nb <- 0 
 39     
 40   
 41  type Index 
 42    field Pointer:IndexNode root 
 43     
 44   
 45 
 
 46  #   IndexNode small computations 
 47   
 48   
 49  gvar IndexNode null_node 
 50  null_node left :> null_node 
 51  null_node right :> null_node 
 52  null_node father :> null_node 
 53   
 54  function build  index 
 55    arg_w Index index 
 56    index root :> null_node 
 57     
 58  function free node 
 59    arg_rw IndexNode node 
 60    if addressof:node=addressof:null_node 
 61      return 
 62    free node:left 
 63    free node:right 
 64    IndexNode destroy_instance addressof:node 
 65    memory_free addressof:node 
 66   
 67  function destroy index 
 68    arg_w Index index 
 69    free index:root 
 70     
 71   
 72  method n biggest_son -> s 
 73    arg IndexNode n ; arg_C IndexNode s 
 74    :> shunt n:left:nb>=n:right:nb n:left n:right 
 75   
 76   
 77  method n adjust_count 
 78    arg_rw IndexNode n 
 79    nb := n:left:nb+n:right:nb+1 
 80   
 81   
 82 
 
 83  #   checking 
 84   
 85   
 86  method index check node 
 87    arg Index index ; arg IndexNode node 
 88    if addressof:node=addressof:null_node 
 89      return 
 90    if node:nb<>node:left:nb+node:right:nb+1 
 91      error error_id_corrupted "Incorrect index (counter) for "+node:key 
 92    if (addressof node:left)<>addressof:null_node 
 93      if node:left:key>node:key 
 94        error error_id_corrupted "Incorrect index (left order)" 
 95      if (addressof node:left:father)<>addressof:node 
 96        error error_id_corrupted "Incorrect index (left son)" 
 97    if (addressof node:right)<>addressof:null_node 
 98      if node:right:key<node:key 
 99        error error_id_corrupted "Incorrect index (right order)" 
 100      if (addressof node:right:father)<>addressof:node 
 101        error error_id_corrupted "Incorrect index (right son)" 
 102    index check node:left 
 103    index check node:right 
 104   
 105  method index check 
 106    arg Index index 
 107    if (addressof index:root)=addressof:null_node 
 108      return 
 109    if (addressof index:root:father)<>addressof:null_node 
 110      error error_id_corrupted "Incorrect index (root)" 
 111    index check index:root 
 112   
 113   
 114  method index display node indent 
 115    arg Index index ; arg Pointer:IndexNode node ; arg Int indent 
 116    if addressof:node=addressof:null_node 
 117      return 
 118    console (repeat indent " ")+node:key+" "+(string node:nb)+" "+(shunt (addressof node:left)<>addressof:null_node "/" " ")+(shunt (addressof node:right)<>addressof:null_node "\" " ")+"[lf]" 
 119    index display node:left indent+2 
 120    index display node:right indent+2 
 121   
 122  method index display_tree 
 123    arg Index index 
 124    index display index:root 0 
 125   
 126   
 127 
 
 128  #   walking 
 129   
 130   
 131  method index first -> cursor 
 132    arg Index index ; arg Pointer:Arrow cursor 
 133    var Pointer:IndexNode node :> index root 
 134    while (addressof node:left)<>addressof:null_node 
 135      node :> node left 
 136    cursor :> node data 
 137   
 138   
 139  method index last -> cursor 
 140    arg Index index ; arg Pointer:Arrow cursor 
 141    var Pointer:IndexNode node :> index root 
 142    while (addressof node:right)<>addressof:null_node 
 143      node :> node right 
 144    cursor :> node data 
 145   
 146   
 147  method index next cursor -> cursor2 
 148    arg Index index ; arg Pointer:Arrow cursor cursor2 
 149    check addressof:cursor<>addressof:null_node 
 150    var Pointer:IndexNode node :> addressof:cursor map IndexNode 
 151    var Pointer:IndexNode node2 
 152    if (addressof node:right)<>addressof:null_node 
 153      node2 :> node right 
 154      while (addressof node2:left)<>addressof:null_node 
 155        node2 :> node2 left 
 156    else 
 157      var Pointer:IndexNode cur :> node ; node2 :> node father 
 158      while addressof:node2<>addressof:null_node and (addressof node2:right)=addressof:cur 
 159        cur :> node2 ; node2 :> node2 father 
 160    cursor2 :> node2 data 
 161   
 162     
 163  method index previous cursor -> cursor2 
 164    arg Index index ; arg Pointer:Arrow cursor cursor2 
 165    check addressof:cursor<>addressof:null_node 
 166    var Pointer:IndexNode node :> addressof:cursor map IndexNode 
 167    var Pointer:IndexNode node2 
 168    if (addressof node:left)<>addressof:null_node 
 169      node2 :> node left 
 170      while (addressof node2:right)<>addressof:null_node 
 171        node2 :> node2 right 
 172    else 
 173      var Pointer:IndexNode cur :> node ; node2 :> node father 
 174      while addressof:node2<>addressof:null_node and (addressof node2:left)=addressof:cur 
 175        cur :> node2 ; node2 :> node2 father 
 176    cursor2 :> node2 data 
 177     
 178   
 179 
 
 180  #   searching 
 181   
 182   
 183  method index first sample -> cursor 
 184    arg Index index ; arg Str sample ; arg Pointer:Arrow cursor 
 185    var Pointer:IndexNode cur :> index root 
 186    while addressof:cur<>addressof:null_node 
 187      var Int := compare sample cur:key 
 188      if c=compare_superior 
 189        cur :> cur right 
 190      eif c=compare_inferior 
 191        cur :> cur left 
 192      else 
 193        var Pointer:IndexNode son :> cur left 
 194        while addressof:son<>addressof:null_node 
 195          if sample=son:key 
 196            cur :> son ; son :> son left 
 197          else 
 198            son :> son right 
 199        cursor :> cur data 
 200        return 
 201    cursor :> cur data 
 202   
 203   
 204  method index next sample cursor -> cursor2 
 205    arg Index index ; arg Str sample ; arg Pointer:Arrow cursor cursor2 
 206    check (addressof:cursor map IndexNode):key=sample 
 207    cursor2 :> index next cursor 
 208    if (addressof:cursor2 map IndexNode):key<>sample 
 209      cursor2 :> null_node data 
 210   
 211  # search for the first greater or equal 
 212  method index from sample -> cursor 
 213    arg Index index ; arg Str sample ; arg Pointer:Arrow cursor 
 214    var Pointer:IndexNode cur :> index root 
 215    while addressof:cur<>addressof:null_node 
 216      var Int := compare cur:key sample 
 217      if c=compare_inferior 
 218        cur :> cur right 
 219      else 
 220        var Pointer:IndexNode son :> cur left 
 221        while addressof:son<>addressof:null_node 
 222          if ((compare son:key sample) .and. compare_superior+compare_equal)<>0 
 223            cur :> son ; son :> son left 
 224          else 
 225            son :> son right 
 226        cursor :> cur data 
 227        return 
 228    cursor :> null_node data 
 229   
 230   
 231  # search for the first greater 
 232  method index to sample -> cursor 
 233    arg Index index ; arg Str sample ; arg Pointer:Arrow cursor 
 234    var Pointer:IndexNode cur :> index root 
 235    while addressof:cur<>addressof:null_node 
 236      var Int := compare cur:key sample 
 237      if c=compare_superior 
 238        cur :> cur left 
 239      else 
 240        var Pointer:IndexNode son :> cur right 
 241        while addressof:son<>addressof:null_node 
 242          if ((compare son:key sample) .and. compare_inferior+compare_equal)<>0 
 243            cur :> son ; son :> son right 
 244          else 
 245            son :> son left 
 246        cursor :> cur data 
 247        cursor :> index next cursor 
 248        return 
 249    cursor :> index first 
 250   
 251   
 252 
 
 253  #   inserting, moving, removing 
 254   
 255   
 256  method index twist fat cur son -> node 
 257    arg_rw Index index ; arg_rw IndexNode fat cur son ; arg_C IndexNode node 
 258    var Pointer:IndexNode grand :> fat father 
 259    if addressof:cur=(addressof fat:right) 
 260      if addressof:son=(addressof cur:right) 
 261        cur father :> grand 
 262        fat father :> cur 
 263        if (addressof cur:left)<>addressof:null_node 
 264          cur:left father :> fat 
 265        fat right :> cur left 
 266        cur left :> fat 
 267        if addressof:grand=addressof:null_node 
 268          index root :> cur 
 269        eif (addressof grand:left)=addressof:fat 
 270          grand left :> cur 
 271        else 
 272          grand right :> cur 
 273        fat adjust_count 
 274        cur adjust_count 
 275        node :> cur 
 276      else 
 277        son father :> grand 
 278        cur father :> son 
 279        fat father :> son 
 280        if (addressof son:left)<>addressof:null_node 
 281          son:left father :> fat 
 282        if (addressof son:right)<>addressof:null_node 
 283          son:right father :> cur 
 284        fat right :> son left 
 285        cur left :> son right 
 286        son left :> fat 
 287        son right :> cur 
 288        if addressof:grand=addressof:null_node 
 289          index root :> son 
 290        eif (addressof grand:left)=addressof:fat 
 291          grand left :> son 
 292        else  
 293          grand right :> son 
 294        fat adjust_count 
 295        cur adjust_count 
 296        son adjust_count 
 297        node :> son 
 298    else 
 299      if addressof:son=(addressof cur:left) 
 300        cur father :> grand 
 301        fat father :> cur 
 302        if (addressof cur:right)<>addressof:null_node 
 303          cur:right father :> fat 
 304        fat left :> cur right 
 305        cur right :> fat 
 306        if addressof:grand=addressof:null_node 
 307          index root :> cur 
 308        eif (addressof grand:left)=addressof:fat 
 309          grand left :> cur 
 310        else 
 311          grand right :> cur 
 312        fat adjust_count 
 313        cur adjust_count 
 314        node :> cur 
 315      else 
 316        son father :> grand 
 317        cur father :> son 
 318        fat father :> son 
 319        if (addressof son:left)<>addressof:null_node 
 320          son:left father :> cur 
 321        if (addressof son:right)<>addressof:null_node 
 322          son:right father :> fat 
 323        fat left :> son right 
 324        cur right :> son left 
 325        son left :> cur 
 326        son right :> fat 
 327        if addressof:grand=addressof:null_node 
 328          index root :> son 
 329        eif (addressof grand:left)=addressof:fat 
 330          grand left :> son 
 331        else  
 332          grand right :> son 
 333        cur adjust_count 
 334        fat adjust_count 
 335        son adjust_count 
 336        node :> son 
 337   
 338   
 339  method index balanceonce -> c 
 340    arg_rw Index index ; arg CBool c 
 341    var Pointer:IndexNode fat :> index root 
 342    if addressof:fat=addressof:null_node 
 343      return false 
 344    var CBool balanced := false 
 345    while true 
 346      var Pointer:IndexNode cur :> fat biggest_son 
 347      if addressof:cur=addressof:null_node 
 348        return balanced 
 349      if 3*cur:nb>2*fat:nb 
 350        fat :> index twist fat cur cur:biggest_son ; balanced := true 
 351      else 
 352        fat :> cur 
 353   
 354   
 355  method index insert key ahead data -> cursor 
 356    arg_rw Index index ; arg Str key ; arg CBool ahead ; arg Address data ; arg Pointer:Arrow cursor 
 357    var Int c ; var Int mode := shunt ahead compare_inferior+compare_equal compare_inferior 
 358    var Pointer:IndexNode fat :> null_node 
 359    var Pointer:IndexNode cur :> index root 
 360    while addressof:cur<>addressof:null_node 
 361      if addressof:fat<>addressof:null_node and 3*cur:nb>2*fat:nb 
 362        fat nb -= 1 
 363        cur :> index twist fat cur cur:biggest_son 
 364        fat :> cur father 
 365      else 
 366        cur nb += 1 
 367        fat :> cur 
 368        := compare key cur:key 
 369        cur :> shunt (.and. mode)<>cur:left cur:right 
 370    var Pointer:IndexNode node :> (memory_allocate IndexNode:size addressof:index) map IndexNode 
 371    IndexNode build_instance addressof:node 
 372    node key := key ; node data := data 
 373    node left :> null_node 
 374    node right :> null_node 
 375    node father :> fat 
 376    node nb := 1 
 377    if addressof:fat=addressof:null_node 
 378      index root :> node 
 379    eif (.and. mode)<>0 
 380      fat left :> node 
 381    else 
 382      fat right :> node 
 383    cursor :> node data 
 384    # index balanceonce 
 385   
 386  method index insert key data -> cursor 
 387    arg_rw Index index ; arg Str key ; arg Address data ; arg Pointer:Arrow cursor 
 388    cursor :> index insert key false data 
 389   
 390   
 391  method index move old new 
 392    arg_rw Index index ; arg_rw IndexNode old new 
 393    check addressof:new<>addressof:old 
 394    var Pointer:IndexNode fat :> old father 
 395    var Pointer:IndexNode left :> old left 
 396    var Pointer:IndexNode right :> old right 
 397    if addressof:fat=addressof:null_node 
 398      check (addressof index:root)=addressof:old 
 399      index root :> new 
 400    eif (addressof fat:left)=addressof:old 
 401      fat left :> new 
 402    eif (addressof fat:right)=addressof:old 
 403      fat right :> new 
 404    else 
 405      error "Corrupted node" 
 406    if addressof:left<>addressof:null_node 
 407      check (addressof left:father)=addressof:old 
 408      left father :> new 
 409    if addressof:right<>addressof:null_node 
 410      check (addressof right:father)=addressof:old 
 411      right father :> new 
 412    new left :> old left 
 413    new right :> old right 
 414    new father :> old father 
 415    new nb := old nb 
 416   
 417  method index remove cursor -> cursor2 
 418    arg_rw Index index ; arg Pointer:Arrow cursor cursor2 
 419    check addressof:cursor<>addressof:null_node 
 420    var Pointer:IndexNode node :> addressof:cursor map IndexNode 
 421    var Pointer:IndexNode next 
 422    if (addressof node:right)=addressof:null_node 
 423      next :> node 
 424      cursor2 :> index next cursor 
 425    else 
 426      next :> node right 
 427      while (addressof next:left)<>addressof:null_node 
 428        next :> next left 
 429      cursor2 :> next data 
 430    var Pointer:IndexNode cur :> next father 
 431    while addressof:cur<>addressof:null_node 
 432      cur nb -= 1 
 433      cur :> cur father 
 434    var Pointer:IndexNode son :> shunt (addressof next:left)<>addressof:null_node next:left next:right 
 435    var Pointer:IndexNode fat :> next father 
 436    if addressof:fat=addressof:null_node 
 437      check (addressof index:root)=addressof:next 
 438      index root :> son 
 439    eif (addressof fat:left)=addressof:next 
 440      fat left :> son 
 441    else 
 442      check (addressof fat:right)=addressof:next 
 443      fat right :> son 
 444    if addressof:son<>addressof:null_node 
 445      son father :> fat 
 446    if addressof:next<>addressof:node 
 447      index move node next 
 448    IndexNode destroy_instance addressof:node 
 449    memory_free addressof:node 
 450    index balanceonce 
 451   
 452  method index remove label data 
 453    arg_rw Index index ; arg Str label ; arg Address data 
 454    var Pointer:Arrow :> index first label 
 455    while c<>null 
 456      if data=null or data=c 
 457        :> index remove c 
 458        if (addressof:map IndexNode):key<>label 
 459          return 
 460      else 
 461        :> index next label c 
 462   
 463   
 464  method index balance 
 465    arg_rw Index index 
 466    while index:balanceonce 
 467      void 
 468   
 469   
 470  export Index IndexNode 
 471  export '. first' '. next' '. last' '. previous' '. from' '. to' 
 472  export '. insert' '. remove' '. move' '. balance' '. check' '. display_tree' 
 473   
 474   
 475  # method c key -> k 
 476  #   arg Pointer:Arrow c ; arg_R Str k 
 477  #   k :> (addressof:c map IndexNode) key 
 478   
 479  # export '. key'