extra/gap-buffer/cursortree/cursortree.factor

   1 ! Copyright (C) 2007 Alex Chapman All Rights Reserved.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: assocs kernel gap-buffer generic trees trees.avl math
   4 sequences quotations ;
   5 IN: gap-buffer.cursortree
   6
   7 TUPLE: cursortree cursors ;
   8
   9 : <cursortree> ( seq -- cursortree )
  10     <gb> cursortree new tuck set-delegate <avl>
  11     over set-cursortree-cursors ;
  12
  13 GENERIC: cursortree-gb ( cursortree -- gb )
  14 M: cursortree cursortree-gb ( cursortree -- gb ) delegate ;
  15 GENERIC: set-cursortree-gb ( gb cursortree -- )
  16 M: cursortree set-cursortree-gb ( gb cursortree -- ) set-delegate ;
  17
  18 TUPLE: cursor i tree ;
  19 TUPLE: left-cursor ;
  20 TUPLE: right-cursor ;
  21
  22 : cursor-index ( cursor -- i ) cursor-i ;
  23
  24 : add-cursor ( cursortree cursor -- ) dup cursor-index rot push-at ;
  25
  26 : remove-cursor ( cursortree cursor -- )
  27     tuck cursor-index swap cursortree-cursors at* [ delete ] [ 2drop ] if ;
  28
  29 : set-cursor-index ( index cursor -- )
  30     dup cursor-tree over remove-cursor tuck set-cursor-i
  31     dup cursor-tree cursortree-cursors swap add-cursor ;
  32
  33 GENERIC: cursor-pos ( cursor -- n )
  34 GENERIC: set-cursor-pos ( n cursor -- )
  35 M: left-cursor cursor-pos ( cursor -- n ) [ cursor-i 1+ ] keep cursor-tree index>position ;
  36 M: right-cursor cursor-pos ( cursor -- n ) [ cursor-i ] keep cursor-tree index>position ;
  37 M: left-cursor set-cursor-pos ( n cursor -- ) >r 1- r> [ cursor-tree position>index ] keep set-cursor-index ;
  38 M: right-cursor set-cursor-pos ( n cursor -- ) [ cursor-tree position>index ] keep set-cursor-index ;
  39
  40 : <cursor> ( cursortree -- cursor )
  41     cursor new tuck set-cursor-tree ;
  42
  43 : make-cursor ( cursortree pos cursor -- cursor )
  44     >r swap <cursor> r> tuck set-delegate tuck set-cursor-pos ;
  45
  46 : <left-cursor> ( cursortree pos -- left-cursor )
  47     left-cursor new make-cursor ;
  48
  49 : <right-cursor> ( cursortree pos -- right-cursor )
  50     right-cursor new make-cursor ;
  51
  52 : cursors ( cursortree -- seq )
  53     cursortree-cursors values concat ;
  54
  55 : cursor-positions ( cursortree -- seq )
  56     cursors [ cursor-pos ] map ;
  57
  58 M: cursortree move-gap ( n cursortree -- )
  59     #! Get the position of each cursor before the move, then re-set the
  60     #! position afterwards. This will update any changed cursor indices.
  61     dup cursor-positions >r tuck cursortree-gb move-gap
  62     cursors r> swap [ set-cursor-pos ] 2each ;
  63
  64 : element@< ( cursor -- pos cursortree ) [ cursor-pos 1- ] keep cursor-tree ;
  65 : element@> ( cursor -- pos cursortree ) [ cursor-pos ] keep cursor-tree ;
  66
  67 : at-beginning? ( cursor -- ? ) cursor-pos 0 = ;
  68 : at-end? ( cursor -- ? ) element@> length = ;
  69
  70 : insert ( obj cursor -- ) element@> insert* ;
  71
  72 : element< ( cursor -- elem ) element@< nth ;
  73 : element> ( cursor -- elem ) element@> nth ;
  74
  75 : set-element< ( elem cursor -- ) element@< set-nth ;
  76 : set-element> ( elem cursor -- ) element@> set-nth ;
  77
  78 GENERIC: fix-cursor ( cursortree cursor -- )
  79
  80 M: left-cursor fix-cursor ( cursortree cursor -- )
  81     >r gb-gap-start 1- r> set-cursor-index ;
  82
  83 M: right-cursor fix-cursor ( cursortree cursor -- )
  84     >r gb-gap-end r> set-cursor-index ;
  85
  86 : fix-cursors ( old-gap-end cursortree -- )
  87     tuck cursortree-cursors at [ fix-cursor ] with each ;
  88
  89 M: cursortree delete* ( pos cursortree -- )
  90     tuck move-gap dup gb-gap-end swap dup (delete*) fix-cursors ;
  91
  92 : delete< ( cursor -- ) element@< delete* ;
  93 : delete> ( cursor -- ) element@> delete* ;
  94