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