unmaintained/isequences/ops/minimum/minimum.factor

   1 ! Copyright (C) 2007 Robbert van Dalen.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 IN: isequences.ops.minimum
   5 USING: generic kernel math sequences isequences.interface isequences.base ;
   6
   7
   8 TUPLE: imin left right ;
   9
  10 : <i-min> ( left right -- imin )
  11     2dup [ i-length ] 2apply min dup rot
  12     swap ihead -rot ihead swap <imin> ; inline
  13
  14 : imin-unpack ( imin -- left right )
  15     dup imin-left swap imin-right ; inline
  16
  17 : imin-v ( v1 v2 -- v )
  18     2dup [ left-side ] 2apply i-cmp dup zero?
  19     [ drop [ right-side ] 2apply 2dup i-cmp 0 < [ 2drop 0 ] [ nip :v: ] if ]
  20     [ 0 < [ 2drop 0 ] [ drop ] if ]
  21     if ; inline
  22
  23 : imin-ileft ( imin -- imin )
  24     imin-unpack ileft dup i-length rot swap ihead swap <i-min> ; inline
  25
  26 : imin-iright ( imin -- imin )
  27     imin-unpack dup ileft i-length rot swap itail swap iright <i-min> ; inline
  28
  29 : &&g++ ( s1 s2 -- imax )
  30     <i-min> ; inline
  31
  32 : &&g-+ ( s1 s2 -- imax )
  33     swap -- `` swap 2dup [ i-length ] 2apply neg + ++ && `` -- ; inline
  34
  35 : &&g+- ( s1 s2 -- imax )
  36     -- `` 2dup -roll [ i-length ] 2apply neg + ++ swap && `` -- ; inline
  37
  38 : &&g-- ( s1 s2 -- imax )
  39     [ -- `` ] 2apply 2dup [ i-length ] 2apply roll || -rot || && `` -- ; inline
  40
  41 : &&g ( s1 s2 -- imin )
  42     2dup [ neg? ] 2apply [ [ &&g-- ] [ &&g+- ] if ]
  43     [ [ &&g-+ ] [ &&g++ ] if ] if ; inline
  44
  45 M: object && &&g ;
  46
  47 M: imin i-length imin-left i-length ;
  48 M: imin i-at swap imin-unpack swap pick i-at -rot swap i-at imin-v ;
  49 M: imin ileft imin-ileft ;
  50 M: imin iright imin-iright ;
  51 M: imin ihead (ihead) ;
  52 M: imin itail (itail) ;
  53 M: imin $$ imin-unpack [ -- $$ neg ] 2apply quick-hash neg ;
  54
  55 ! double dispatch integer/&&
  56 GENERIC: integer/&& ( s1 s2 -- v )
  57 M: object integer/&& swap &&g ;
  58 M: integer && swap integer/&& ;
  59 ! integer optimization
  60 M: integer integer/&& min ;