ybot_base.xtm

;; lib-loading config
(if *impc:compiler:with-cache* (sys:load "libs/aot-cache/ybot_base.xtm" 'quiet))
(sys:load-preload-check 'ybot_base)
(define *xtmlib-ybot_base-loaded* #t)

(impc:aot:suppress-aot-do (sys:load "libs/core/adt.xtm"))
(impc:aot:insert-forms (sys:load "libs/core/adt.xtm" 'quiet))

(impc:aot:insert-header "xtmybot_base")
(impc:aot:import-ll "xtmybot_base")
 

;; Convenience utilities
(bind-macro (@ . args)
  `(pref ,(car args) 0))

;;; left curry ;;;
;; curry: f(x1,x2,x3...), x2, x3, ... -> g(x1)  
(bind-macro (curry . args)
  `(lambda (x) (,(car args) x ,@(cdr args))))

(bind-func non-null:[bool,i8*]*
  (lambda (p)
    (not (null? p))))

(bind-func non-null:[bool,!a]*
  (lambda (p)
    (not (null? (cast p i8*)))))

(bind-func non-empty:[bool,List{!a}*]*
  (lambda (lst)
    (and (non-null lst) (< 0 (length lst)))))

(bind-func empty:[bool,List{!a}*]*
  (lambda (lst)
    (or (null? lst) (= 0 (length lst)))))

(bind-func non-empty:[bool,String*]*
  (lambda (str)
    (and (non-null str) (< 0 (length str)))))

(bind-func empty:[bool,String*]*
  (lambda (str)
    (or (null? str) (= 0 (length str)))))


;; This is a convenient way of checking something is not-null before doing stuff with it
(bind-macro (con . args)
            `(cond
              ((non-null ,(car args))
               (begin ,@(cdr args) void))
              (else void)))


;; For literal binary numbers i.e. decimal 14 = hex e = (binary "1110")   
(bind-func binary:[i8,i8*]*
  (lambda (digits)
    (let ((n:i64 (strlen digits))
          (loop
           (lambda (cc:i64 b:i8)
             (cond
              ((< cc (min n 8))
               (cond
                ((= (pref digits (- (- n 1) cc)) (i64toi8 49))
                 (loop (+ cc 1) (+ b (i64toi8 (<< 1 cc)))))
                (else
                 (loop (+ cc 1) b))))
              (else
               b)))))
      (loop 0 0))))


;; big endian combination of bytes
(bind-func be_literal:[i64,List{i8}*]*
  (lambda (bytes)
    (let ((loop 
            (lambda
              (lst:List{i8}* j:i64 x:i64)
              (cond 
               ((and (non-empty lst) (< j 8))
                (loop (cdr lst) (+ j 1) (bor x (<< (i8toui64 (car lst)) (* 8 j)))))
                (else x)))))
      (loop (reverse bytes) 0 0))))


;; little endian combination of bytes
(bind-func le_literal:[i64,List{i8}*]*
  (lambda (bytes)
    (let ((loop 
            (lambda
              (lst:List{i8}* j:i64 x:i64)
              (cond 
               ((and (non-empty lst) (< j 8))
                (loop (cdr lst) (+ j 1) (bor x (<< (i8toui64 (car lst)) (* 8 j)))))
                (else x)))))
      (loop (reverse bytes) 0 0))))


(bind-func bb:[i64,i8*,i64]*
  (lambda (bstr:i8* n:i64)
    (let ((lst:List{i8}* (map_t (lambda (m:i64) (binary "00000000")) (range n))))
      (be_literal (cons (binary bstr) lst)))))


(bind-func print_byte:[void,i64]*
  (lambda (d)
    (let* ((bits:|8,bool|* (alloc)))
      (doloop (n 8)
        (aset! bits n (not (= 0 (modulo d 2))))
        (set! d (/ d 2)))
      (doloop (m 8)
        (if (aref bits (- 7 m))
            (printf "%d" 1)
            (printf "%d" 0)))
      (printf "\n")
      void)))


(bind-func print_data:[void,i8*,i64]*
  (lambda (data sz)
    (doloop (i sz)
      (cond
       ((= (pref data i) 0:i8)
        (printf "_"))
       (else
        (printf "%c" (pref data i)))))
    ;(printf "\n")
    void))


;; For colourful log printing
(bind-func colour_pencil:[void,i8*]*
  (lambda (name)
  (let ((n:i8
         (cond
          ((= (i64toi32 0) (strcmp name "black")) (i64toi8 30))
          ((= (i64toi32 0) (strcmp name "red")) (i64toi8 31))
          ((= (i64toi32 0) (strcmp name "green")) (i64toi8 32))
          ((= (i64toi32 0) (strcmp name "yellow")) (i64toi8 33))
          ((= (i64toi32 0) (strcmp name "blue")) (i64toi8 34))
          ((= (i64toi32 0) (strcmp name "magenta")) (i64toi8 35))
          ((= (i64toi32 0) (strcmp name "cyan")) (i64toi8 36))
          ((= (i64toi32 0) (strcmp name "white")) (i64toi8 37))
          (else (i64toi8 0)))))
    (printf "%c[%dm" (i64toi8 27) n)
    void)))


(bind-func highlighter:[void,i8*]*
  (lambda (name)
  (let ((n:i8
         (cond
          ((= (i64toi32 0) (strcmp name "black")) (i64toi8 40))
          ((= (i64toi32 0) (strcmp name "red")) (i64toi8 41))
          ((= (i64toi32 0) (strcmp name "green")) (i64toi8 42))
          ((= (i64toi32 0) (strcmp name "yellow")) (i64toi8 43))
          ((= (i64toi32 0) (strcmp name "blue")) (i64toi8 44))
          ((= (i64toi32 0) (strcmp name "magenta")) (i64toi8 45))
          ((= (i64toi32 0) (strcmp name "cyan")) (i64toi8 46))
          ((= (i64toi32 0) (strcmp name "white")) (i64toi8 47))
          (else (i64toi8 0)))))
    (printf "%c[%dm" (i64toi8 27) n)
    void)))



;; Naive sorting algorithm - no attempt at optimisation
;; Start with tmp list of already-sorted elements
;; for each element in list, see where it fits into the already-sorted list - insert it there and remove it from the to-be-sorted
(bind-func sort:[List{!a}*,List{!a}*,List{!a}*,[bool,!a,!a]*]*
  (lambda (to_be_sorted already_sorted cmp)
    (if (null? to_be_sorted)
        already_sorted
        (let* ((x (car to_be_sorted))
               (y (cdr to_be_sorted))
               (n:i64 (length already_sorted))
               (loop:[List*,i64]*
               (lambda (index:i64)
                 (cond
                  ((= n 0)
                   (cons x already_sorted))
                  ((>= index n)
                   (insert already_sorted n x))
                  ((cmp x (nth already_sorted index))
                   (insert already_sorted index x))
                  (else (loop (+ index 1)))))))
          (sort y (loop 0) cmp)))))


;; convenience wrapper around the (member) function that returns true/false
(bind-func contains:[bool,!a,List{!a}*]*
  (lambda (element lst)
    (non-empty (member element lst))))

;; Standard string join function (for some reason is missing from the extempore std library)
(bind-func join:[String*,String*,List{String*}*]*
  (lambda (delim lst)
    (cond
     ((null? lst) null)
     (else
      (let* ((stl:List{String*}* (reverse lst))
             (loop (lambda (input:List{String*}* output:String*)
                     (cond
                      ((null? input) output)
                      (else
                       (loop (cdr input) (cat (car input) (cat delim output))))))))
        (loop (cdr stl) (car stl)))))))


;; Extra string functions
(bind-func cstring:[i8*,i8]*
  (lambda (c)
    (let ((p:i8* (zalloc 2)))
      (pset! p 0 c)
      (pset! p 1 0)
      p)))

(bind-func to_lower:[i8,i8]*
  (lambda (c)
    (if (and (< (i64toi8 64) c) (< c (i64toi8 91)))
        (+ c (i64toi8 32))
        c)))

(bind-func to_upper:[i8,i8]*
  (lambda (c)
    (if (and (< (i64toi8 96) c) (< c (i64toi8 123)))
        (- c (i64toi8 32))
        c)))


(bind-func lower:[String*,i8*]*
  (lambda (cstr)
    (let* ((i:i64 0) (n:i64 (strlen cstr))
           (buffer:i8* (zalloc (+ n 1))))
      (dotimes (i n)
        (pset! buffer i (to_lower (pref cstr i))))
      (pset! buffer n 0)
      (String buffer))))
        

(bind-func lower:[String*,String*]*
  (lambda (str:String*)
    (let ((cstr:i8* (cstring str)))
    (lower:[String*,i8*]* cstr))))
    

(bind-func upper:[String*,i8*]*
  (lambda (cstr)
    (let* ((i:i64 0) (n:i64 (strlen cstr))
           (buffer:i8* (zalloc (+ n 1))))
      (dotimes (i n)
        (pset! buffer i (to_upper (pref cstr i))))
      (pset! buffer n 0)
      (String buffer))))


(bind-func upper:[String*,String*]*
  (lambda (str:String*)
    (let ((cstr:i8* (cstring str)))
    (upper:[String*,i8*]* cstr))))


(bind-func print_hex:[void,String*]*
  (lambda (str)
    (let ((i:i64 0)
          (n:i64 (length str))
          (data:i8* (tref str 1)))
      (dotimes (i (- n 1))
        (printf "%02X " (pref data i)))
      (printf "%02X" (pref data (- n 1)))
      void)))

(bind-func print_hex:[void,i8*,i64]*
  (lambda (data n)
    (let ((i:i64 0))
      (dotimes (i (- n 1))
        (cond
         ((= 3 (modulo i 4))
          (printf "%02X " (pref data i)))
         (else (printf "%02X." (pref data i)))))
      (printf "%02X" (pref data (- n 1)))
      void)))



(bind-func print_sanitised:[void,String*]*
  (lambda (str:String*)
    (cond
     ((non-null str)
      (let ((i:i64 0) (n:i64 (length str))
             (data:i8* (tref str 1)))
         (dotimes (i n)
           (let ((c:i8 (pref data i)))
             (cond
              ((< 31:i8 c)
               (printf "%c" c))
              (else 
               (printf "[%02X]" c)))))
         void))
     (else void))))


;; override base.xtm string comparison, so that it doesn't crash on null
(bind-func equal
  (lambda (s1:String* s2:String*)
    (if (or (null? s1) (null? s2))
        0:i1
        (if (= (strcmp (tref s1 1) (tref s2 1)) 0)
            1:i1 0:i1))))


(bind-func safe_cstr:[i8*,String*]*
  (lambda (str:String*)
    (cond
     ((non-null str)
      (cstring str))
     (else
      (zalloc)))))
        

;; String parsing utilities
(bind-func first_word:[String*,String*]*
  (lambda (str)
    (let ((words (regex_split "[^a-zA-Z0-9]+" str)))
      (if (non-empty words)
          (car words)
          null))))


(bind-func last_word:[String*,String*]*
  (lambda (str)
    (let ((words (regex_split "[^a-zA-Z0-9]+" str)))
      (if (non-empty words)
          (car (reverse words))
          null))))

;; List style string functions
(bind-func top:[i8,String*]*
  (lambda (str)
    (cond
     ((non-empty str) (pref (tref str 1) 0))
     (else 0:i8))))


(bind-func tail:[String*,String*]*
  (lambda (str)
    (cond
     ((non-empty str) (substring str 1 (length str)))
     (else null))))

(impc:aot:insert-footer "xtmybot_base")