core/math/order/order.factor

   1 ! Copyright (C) 2008 Slava Pestov, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel math ;
   4 IN: math.order
   5
   6 SYMBOL: +lt+
   7 SYMBOL: +eq+
   8 SYMBOL: +gt+
   9
  10 : invert-comparison ( <=> -- <=>' )
  11     #! Can't use case, index or nth here
  12     dup +lt+ eq? [ drop +gt+ ] [ +eq+ eq? +eq+ +lt+ ? ] if ;
  13
  14 GENERIC: <=> ( obj1 obj2 -- <=> )
  15
  16 M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ;
  17
  18 GENERIC: before? ( obj1 obj2 -- ? )
  19 GENERIC: after? ( obj1 obj2 -- ? )
  20 GENERIC: before=? ( obj1 obj2 -- ? )
  21 GENERIC: after=? ( obj1 obj2 -- ? )
  22
  23 M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ;
  24 M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ;
  25 M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ;
  26 M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ;
  27
  28 M: real before? ( obj1 obj2 -- ? ) < ;
  29 M: real after? ( obj1 obj2 -- ? ) > ;
  30 M: real before=? ( obj1 obj2 -- ? ) <= ;
  31 M: real after=? ( obj1 obj2 -- ? ) >= ;
  32
  33 : min ( x y -- z ) [ before? ] most ; inline
  34 : max ( x y -- z ) [ after? ] most ; inline
  35
  36 : between? ( x y z -- ? )
  37     pick after=? [ after=? ] [ 2drop f ] if ; inline
  38
  39 : [-] ( x y -- z ) - 0 max ; inline
  40
  41 : compare ( obj1 obj2 quot -- <=> ) bi@ <=> ; inline