unmaintained/isequences/ops/maximum/maximum.factor

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