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 : >=< ( obj1 obj2 -- >=< ) <=> invert-comparison ; inline
  17
  18 M: real <=> 2dup < [ 2drop +lt+ ] [ number= +eq+ +gt+ ? ] if ;
  19
  20 GENERIC: before? ( obj1 obj2 -- ? )
  21 GENERIC: after? ( obj1 obj2 -- ? )
  22 GENERIC: before=? ( obj1 obj2 -- ? )
  23 GENERIC: after=? ( obj1 obj2 -- ? )
  24
  25 M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ;
  26 M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ;
  27 M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ;
  28 M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ;
  29
  30 M: real before? ( obj1 obj2 -- ? ) < ;
  31 M: real after? ( obj1 obj2 -- ? ) > ;
  32 M: real before=? ( obj1 obj2 -- ? ) <= ;
  33 M: real after=? ( obj1 obj2 -- ? ) >= ;
  34
  35 : min ( x y -- z ) [ before? ] most ; inline
  36 : max ( x y -- z ) [ after? ] most ; inline
  37 : clamp ( x min max -- y ) [ max ] dip min ; inline
  38
  39 : between? ( x y z -- ? )
  40     pick after=? [ after=? ] [ 2drop f ] if ; inline
  41
  42 : [-] ( x y -- z ) - 0 max ; inline
  43
  44 : compare ( obj1 obj2 quot -- <=> ) bi@ <=> ; inline