# 
# A small library of useful Scheme functions, mainly from SLIB
# paste: concatenates list of strings into one, separating with " "
# subset: select members of list by position
# seq: gives sequence of integers 
#
# SET type functions
# delete-duplicates: drops duplicates from a list (set)
# merge!: merge two sorted lists
# sort!: sort a list
# filter: extract list members meeting a criterion
# intersection: give overlapping members of two lists
#
#
# Preceded by two examples of their use in Sib-pair macros
#
# K nearest neighbouring markers
# usage: nearest K loc1...locN
#
macro nearest 
  macro mset = %+2
  eval (define neighbours \
          (paste (intersection (ls "m") \
                  (map loc \
                     (neighbouring \ 
                       (map locord (string-split mset)) (max (string->number "$1") 5))))))
echo
echo Markers close to "%mset": neighbours="%neighbours"
echo
;;;;
#
# Read a column of a (rectangular) data file
# usage: readcol fil col
#
macro readcol
  eval (define var%2 (paste (readvar "%1" %2)))
;;;;
eval (define (readvar file col) \
  (begin  \
    (define dat (open-input-file file)) \
    (define res (let loop ((lin (read-line dat)) (res '()))  \
       (if (string? lin)   \
         (loop (read-line dat) \
               (let ((vars (string-split lin))) \
                   (cons (if (> col (length vars)) "" (list-ref vars (- col 1))) res))) \
         res))) \
    (close-input-port dat)) \
   (reverse res))
#
# Convert list to string
#
eval (define (paste x) \
  (if (atom? x) \
    x \
    (string-append (car x) \
      (apply string-append \
        (map (lambda (x) (string-append " " x)) (cdr x))))))
#
# Indexed subset of list
#
eval (define (subset x indices) \
  (if (atom? indices) \
    (list-ref x (max 0 (- indices 1))) \
    (map (lambda (i) (list-ref x (max 0 (- i 1)))) indices)))
#
# Span of indices around target
#
eval (define (neighbouring x span) \
  (if (atom? x) \
    (define n (seq (max 1 (- x span)) (min (nloci) (+ x span)))) \
    (define n (apply append (map (lambda (x) \
      (seq (max 1 (- x span)) (min (nloci) (+ x span)))) x)))) \
  (sort! (delete-duplicates n =) <))
#
# From primes by Ozan Yigit
#
eval (define (seq m n) \
  (if (> m n) \
      '() \
      (cons m (seq (+ 1 m) n))))
#
# From SRFI-1 O(n^2) as unsorted list
#
eval (define (delete-duplicates l =?) \
      (let loop ((l l) (r '())) \
        (if (null? l) \
          (reverse r) \
          (loop (cdr l) \
                (if (member (car l) r =?) r (cons (car l) r))))))
#
# merge-sort a list destructively (RA O'Keefe, DHD Warren)
#   (sort! sequence less?)
# Calls
#   (merge! a b less?)
# takes two sorted lists a and b and smashes their cdr fields to form a
# single sorted list including the elements of both.
#
eval (define (merge! a b less?) \
 (define (loop r a b) \
   (if (less? (car b) (car a)) \
       (begin \
           (set-cdr! r b) \
           (if (null? (cdr b)) \
               (set-cdr! b a) \
               (loop b a (cdr b)) )) \
       (begin \
           (set-cdr! r a) \
           (if (null? (cdr a)) \
               (set-cdr! a b) \
               (loop a (cdr a) b)) )) ) \
 (cond \
      ((null? a) b) \
      ((null? b) a) \
      ((less? (car b) (car a)) \
          (if (null? (cdr b)) \
              (set-cdr! b a) \
              (loop b a (cdr b))) \
          b) \
      (else \
          (if (null? (cdr a)) \
              (set-cdr! a b) \
              (loop a (cdr a) b)) \
          a)))
eval (define (sort! seq less?) \
    (define (step n) \
         (cond \
             ((> n 2) \
                 (let* ((j (quotient n 2)) \
                        (a (step j)) \
                        (k (- n j)) \
                        (b (step k))) \
                     (merge! a b less?))) \
             ((= n 2) \
                 (let ((x (car seq)) \
                       (y (cadr seq)) \
                       (p seq)) \
                     (set! seq (cddr seq)) \
                     (if (less? y x) (begin \
                         (set-car! p y) \
                         (set-car! (cdr p) x))) \
                     (set-cdr! (cdr p) '()) \
                     p)) \
             ((= n 1) \
                 (let ((p seq)) \
                     (set! seq (cdr seq)) \
                     (set-cdr! p '()) \
                     p)) \
             (else \
                 '()))) \
    (step (length seq))) 
#
# SRFI1 filter
#
eval (define (filter pred lis) \
  (let recur ((lis lis)) \
    (if (atom? lis 'FILTER) \
        lis \
        (let ((head (car lis)) \
              (tail (cdr lis))) \
          (if (pred head) \
              (let ((new-tail (recur tail))) \
                (if (eq? tail new-tail) lis \
                    (cons head new-tail))) \
              (recur tail))))))
#
# set intersection
#
eval (define (intersection lst1 lst2) \
  (if (null? lst2) \
    lst2 \
    (let build-intersection ((lst1 lst1) \
                             (result '())) \
      (cond ((null? lst1) (reverse result)) \
        ((memv (car lst1) lst2) \
         (build-intersection (cdr lst1) (cons (car lst1) result))) \
        (else \
         (build-intersection (cdr lst1) result))))))