hl2b/bootstrap.arc: when compiling cs/, don't eval by default

; front end to the bytecode compiler
; loads all the files and defines an entry function

; define the <hl> package and import functions and macros needed
; by the compiler from <arc>v3
; TODO: move in a file conditionally loaded only when bootstrapping
;       using hl-arc-f
(in-package hl)
(using <arc>v3)
; Should really use <hl>def, not just def, because def in this
; context will be <arc>def.  Same with <hl>type etc.
; Please see http://hl.webhop.net/item?id=103 ; I recommended
; using 3 sections, and specified which ones should specify
; specific packages, and which ones just use <arc> packages.
(interface v0 def mac if and no or each load string unpkg prn = w/infile
              let with withs fn afn require w/uniq coerce + push listtab
              givens make-br-fn ++ acons ssyntax isnt caris _ in type isa
              alist err is car cons cdr map orf awhen do trav+ when ontable
              list aif zap self rfn pos complement dotted len on
              index copy mappend cadr cddr len> it some assert given case
              >= > keep idfn rev - mem max mapeach atom bound rep apply
              ; types
              int num char table string sym bool)

(set <hl>unpkg <arc>unpkg)
(set <hl>ssyntax <arc>ssyntax)
(set <hl>pos <arc>pos)

; fix differences between the host and the target
; this is actually a superset, i.e. they do *at least* what their hl
; counterpart do
(mac <axiom>lambda (args . body)
  `(fn ,args ,@body))

(set <axiom>tag <arc>annotate)
(set <axiom>cons <arc>cons)
(set <axiom>i- -)
(set <axiom>i+ +)
(set <axiom>i* *)
(set <axiom>i< <)
(set <axiom>is is)
(set <axiom>cdr cdr)
(set <axiom>car car)

; the compiler package
(in-package compiler)
(using <hl>v0)

(interface v0 compile)

; this var tells if we are bootstrapping the compiler or not
(set bootstrap* t)
; tells if the host should eval the code before compiling it
; eval is needed to get macros to work while bootstrapping
; but the host doesn't support some things (mainly async I/O & processes)
(set stop-host-eval* nil)

; strictly, "compiled-and-executed-files"
(set files* '("structs.hl" "bytecodegen.hl"
              "quote-lift.hl" "utils.hl" "closures.hl" "cps.hl"
              "sharedvars.hl"  "xe.hl" "macex.hl"))
; need also *another* set of files for "compiled-only-but-not-executed-files"

; load all the files
(each f files*
  (load f))

; entry point
; return a 0 arg function that executes expr
;(def compile (expr)
;  (<axiom>assemble (compile-to-bytecode expr)))
; above doesn't actually make sense from within
; Arc-F, because Arc-F doesn't support <axiom>assemble.
; Maybe should be in the "compiled-but-not-executed"
; set of files

(using <read-cs-dir>v1)

(if (> (len <arc>argv) 1)
    ; called from the command line
    ; compile and run the program
    (<arc>w/infile in (<arc>argv 1)
      (= exprs* (<arc>readall in)))
    (do (= exprs* (read-cs-dir))
        (= stop-host-eval* t)))

(do
  (do
    (withs (exprs exprs*
            prog `((<axiom>lambda () ,@exprs)))
      (<arc>w/outfile tmp "/tmp/hl-tmp"
        ; not the best thing to do, pipe-to would be better if we had it
        ; put the default continuation
        (<arc>write '(<bc>k-closure 0
                       (<bc>debug-name final-return)
                       (<bc>check-vars 2)
                       (<bc>local 1)
                       (<bc>halt))
                    tmp)
        (prn "pre-eval")
        (each expr exprs
          ; for each expression, we compile it & then eval it
          ; when bootstrapping evaluation is done in the host
          ; and the compiled result is not executed
          ; WARNING: the *whole* file is evaluated before compilation
          ; takes place. This means that if a global var is redefined
          ; by the compiled code, during compilation only the last definition
          ; will be available. This shouldn't be a problem in practice.
          (if
            (and (isa expr 'sym) (is (unpkg expr) (unpkg '>stop-host-eval)))
              (set stop-host-eval* t)
            (and (isa expr 'sym) (is (unpkg expr) (unpkg '>start-host-eval)))
              (set stop-host-eval* nil)
            (and bootstrap* (no stop-host-eval*))
              (<arc>eval (<compiler>macex expr))))
        (prn "compile")
        (each bc (compile-to-bytecode prog)
          (prn bc) ; for debugging
          (<arc>write bc tmp)))))
  ; run the bytecode (only for testing, will be removed in the future)
  (<arc>system:string "../src/hl --bc /tmp/hl-tmp"))

; front end to the bytecode compiler
; loads all the files and defines an entry function

; define the <hl> package and import functions and macros needed
; by the compiler from <arc>v3
; TODO: move in a file conditionally loaded only when bootstrapping
;       using hl-arc-f
(in-package hl)
(using <arc>v3)
; Should really use <hl>def, not just def, because def in this
; context will be <arc>def.  Same with <hl>type etc.
; Please see http://hl.webhop.net/item?id=103 ; I recommended
; using 3 sections, and specified which ones should specify
; specific packages, and which ones just use <arc> packages.
(interface v0 def mac if and no or each load string unpkg prn = w/infile
              let with withs fn afn require w/uniq coerce + push listtab
              givens make-br-fn ++ acons ssyntax isnt caris _ in type isa
              alist err is car cons cdr map orf awhen do trav+ when ontable
              list aif zap self rfn pos complement dotted len on
              index copy mappend cadr cddr len> it some assert given case
              >= > keep idfn rev - mem max mapeach atom bound rep apply
              ; types
              int num char table string sym bool)

(set <hl>unpkg <arc>unpkg)
(set <hl>ssyntax <arc>ssyntax)
(set <hl>pos <arc>pos)

; fix differences between the host and the target
; this is actually a superset, i.e. they do *at least* what their hl
; counterpart do
(mac <axiom>lambda (args . body)
  `(fn ,args ,@body))

(set <axiom>tag <arc>annotate)
(set <axiom>cons <arc>cons)
(set <axiom>i- -)
(set <axiom>i+ +)
(set <axiom>i* *)
(set <axiom>i< <)
(set <axiom>is is)
(set <axiom>cdr cdr)
(set <axiom>car car)

; the compiler package
(in-package compiler)
(using <hl>v0)

(interface v0 compile)

; this var tells if we are bootstrapping the compiler or not
(set bootstrap* t)
; tells if the host should eval the code before compiling it
; eval is needed to get macros to work while bootstrapping
; but the host doesn't support some things (mainly async I/O & processes)
(set stop-host-eval* nil)

; strictly, "compiled-and-executed-files"
(set files* '("structs.hl" "bytecodegen.hl"
              "quote-lift.hl" "utils.hl" "closures.hl" "cps.hl"
              "sharedvars.hl"  "xe.hl" "macex.hl"))
; need also *another* set of files for "compiled-only-but-not-executed-files"

; load all the files
(each f files*
  (load f))

; entry point
; return a 0 arg function that executes expr
;(def compile (expr)
;  (<axiom>assemble (compile-to-bytecode expr)))
; above doesn't actually make sense from within
; Arc-F, because Arc-F doesn't support <axiom>assemble.
; Maybe should be in the "compiled-but-not-executed"
; set of files

(using <read-cs-dir>v1)

(if (> (len <arc>argv) 1)
    ; called from the command line
    ; compile and run the program
    (<arc>w/infile in (<arc>argv 1)
      (= exprs* (<arc>readall in)))
    (= exprs* (read-cs-dir)))

(do
  (do
    (withs (exprs exprs*
            prog `((<axiom>lambda () ,@exprs)))
      (<arc>w/outfile tmp "/tmp/hl-tmp"
        ; not the best thing to do, pipe-to would be better if we had it
        ; put the default continuation
        (<arc>write '(<bc>k-closure 0
                       (<bc>debug-name final-return)
                       (<bc>check-vars 2)
                       (<bc>local 1)
                       (<bc>halt))
                    tmp)
        (each expr exprs
          ; for each expression, we compile it & then eval it
          ; when bootstrapping evaluation is done in the host
          ; and the compiled result is not executed
          ; WARNING: the *whole* file is evaluated before compilation
          ; takes place. This means that if a global var is redefined
          ; by the compiled code, during compilation only the last definition
          ; will be available. This shouldn't be a problem in practice.
          (if
            (is expr (unpkg '>stop-host-eval))
              (set stop-host-eval* t)
            (is expr (unpkg '>start-host-eval))
              (set stop-host-eval* nil)
            (and bootstrap* (no stop-host-eval*))
              (<arc>eval (<compiler>macex expr))))
        (each bc (compile-to-bytecode prog)
          (prn bc) ; for debugging
          (<arc>write bc tmp)))))
  ; run the bytecode (only for testing, will be removed in the future)
  (<arc>system:string "../src/hl --bc /tmp/hl-tmp"))


add majors for wd & acd

add majors for wd & acd

#	$OpenBSD: files.arc,v 1.8 1996/09/24 21:30:00 niklas Exp $
#
# maxpartitions must be first item in files.${ARCH}
#
maxpartitions 16

maxusers 2 8 64

#	Required files

file	arch/arc/arc/autoconf.c
file	arch/arc/arc/conf.c
file	arch/arc/arc/cpu_exec.c
file	arch/arc/arc/disksubr.c
file	arch/arc/dev/dma.c
file	arch/arc/arc/machdep.c
file	arch/arc/arc/minidebug.c
file	arch/arc/arc/mem.c
file	arch/arc/arc/pmap.c
file	arch/arc/arc/process_machdep.c
file	arch/arc/arc/sys_machdep.c
file	arch/arc/arc/trap.c
file	arch/arc/arc/vm_machdep.c

file	arch/arc/arc/arcbios.c

#
#	Machine-independent ATAPI drivers
#
include "../../../dev/atapi/files.atapi"
major	{ acd = 5 }

#
#	System BUS types
#
define	mainbus {}
device	mainbus
attach	mainbus at root
file	arch/arc/arc/mainbus.c	mainbus

#	Our CPU configurator
device	cpu
attach	cpu at mainbus			# not optional
file arch/arc/arc/cpu.c			cpu

#
#	PICA bus autoconfiguration devices
#
device	pica {}
attach	pica at mainbus			#
file	arch/arc/pica/picabus.c		pica

#
#	ISA Bus bridge
#
device	isabr {} : isabus
attach	isabr at mainbus
file	arch/arc/isa/isabus.c		isabr
file    arch/arc/isa/isadma.c		isadma needs-flag

#	Ethernet chip
device	sn
attach	sn at pica: ifnet, ether
file	arch/arc/dev/if_sn.c		sn	needs-count

#	Use machine independent SCSI driver routines
include	"../../../scsi/files.scsi"
major	{sd = 0}
major	{cd = 3}

#	Machine dependent SCSI interface driver
device	asc: scsi
attach	asc at pica
file	arch/arc/dev/asc.c		asc	needs-count

#	Floppy disk controller
device	fdc {drive = -1}
attach	fdc at pica
device	fd: disk
attach	fd at fdc
file	arch/arc/dev/fd.c		fdc	needs-flag
major	{fd = 7}

#
#	Stock ISA bus support
#
define  pcmcia {}			# XXX dummy decl...
define  pci {}				# XXX dummy decl...

include	"../../../dev/isa/files.isa"
major	{ wd = 4 }

#	Real time clock, must have one..
device	clock
attach	clock at pica with clock_pica
attach	clock at isa with clock_isa
file	arch/arc/arc/clock.c	clock & (clock_isa | clock_pica) needs-flag
file	arch/arc/arc/clock_mc.c	clock & (clock_isa | clock_pica) needs-flag

#	Console driver on PC-style graphics
device	pc: tty
attach	pc at pica with pc_pica
attach	pc at isa with pc_isa
device	pms: tty
attach	pms at pica
file	arch/arc/dev/pccons.c		pc & (pc_pica | pc_isa)	needs-flag

#	Serial driver for both ISA and LOCAL bus.
device  ace: tty
attach  ace at isa with ace_isa
attach  ace at commulti with ace_commulti
attach  ace at pica with ace_pica
file    arch/arc/dev/ace.c		ace & (ace_isa | ace_commulti | ace_pica) needs-flag

# 	Parallel ports (XXX what chip?)
device  lpr
attach  lpr at isa with lpr_isa
attach	lpr at pica with lpr_pica
file	arch/arc/dev/lpr.c		lpr & (lpr_isa | lpr_pica) needs-flag

# BusLogic BT-445C VLB SCSI Controller. Special on TYNE local bus.
device  btl: scsi
attach  btl at isa
file    arch/arc/dti/btl.c                    btl needs-count

# National Semiconductor DS8390/WD83C690-based boards
# (WD/SMC 80x3 family, SMC Ultra [8216], 3Com 3C503, NE[12]000, and clones)
# XXX conflicts with other ports; can't be in files.isa
device  ed: ether, ifnet
attach  ed at isa with ed_isa
attach  ed at pcmcia with ed_pcmcia
file    dev/isa/if_ed.c                 ed & (ed_isa | ed_pcmcia) needs-flag

#

file	dev/cons.c
file	dev/cninit.c
file	netinet/in_cksum.c
file	netns/ns_cksum.c			ns

file	compat/ultrix/ultrix_misc.c		compat_ultrix
file	compat/ultrix/ultrix_syscalls.c		compat_ultrix
file	compat/ultrix/ultrix_sysent.c		compat_ultrix

#	$OpenBSD: files.arc,v 1.7 1996/09/19 00:30:37 imp Exp $
#
# maxpartitions must be first item in files.${ARCH}
#
maxpartitions 16

maxusers 2 8 64

#	Required files

file	arch/arc/arc/autoconf.c
file	arch/arc/arc/conf.c
file	arch/arc/arc/cpu_exec.c
file	arch/arc/arc/disksubr.c
file	arch/arc/dev/dma.c
file	arch/arc/arc/machdep.c
file	arch/arc/arc/minidebug.c
file	arch/arc/arc/mem.c
file	arch/arc/arc/pmap.c
file	arch/arc/arc/process_machdep.c
file	arch/arc/arc/sys_machdep.c
file	arch/arc/arc/trap.c
file	arch/arc/arc/vm_machdep.c

file	arch/arc/arc/arcbios.c

#
#	Machine-independent ATAPI drivers
#
include "../../../dev/atapi/files.atapi"

#
#	System BUS types
#
define	mainbus {}
device	mainbus
attach	mainbus at root
file	arch/arc/arc/mainbus.c	mainbus

#	Our CPU configurator
device	cpu
attach	cpu at mainbus			# not optional
file arch/arc/arc/cpu.c			cpu

#
#	PICA bus autoconfiguration devices
#
device	pica {}
attach	pica at mainbus			#
file	arch/arc/pica/picabus.c		pica

#
#	ISA Bus bridge
#
device	isabr {} : isabus
attach	isabr at mainbus
file	arch/arc/isa/isabus.c		isabr
file    arch/arc/isa/isadma.c		isadma needs-flag

#	Ethernet chip
device	sn
attach	sn at pica: ifnet, ether
file	arch/arc/dev/if_sn.c		sn	needs-count

#	Use machine independent SCSI driver routines
include	"../../../scsi/files.scsi"
major	{sd = 0}
major	{cd = 3}

#	Machine dependent SCSI interface driver
device	asc: scsi
attach	asc at pica
file	arch/arc/dev/asc.c		asc	needs-count

#	Floppy disk controller
device	fdc {drive = -1}
attach	fdc at pica
device	fd: disk
attach	fd at fdc
file	arch/arc/dev/fd.c		fdc	needs-flag
major	{fd = 7}

#
#	Stock ISA bus support
#
define  pcmcia {}			# XXX dummy decl...
define  pci {}				# XXX dummy decl...

include	"../../../dev/isa/files.isa"

#	Real time clock, must have one..
device	clock
attach	clock at pica with clock_pica
attach	clock at isa with clock_isa
file	arch/arc/arc/clock.c	clock & (clock_isa | clock_pica) needs-flag
file	arch/arc/arc/clock_mc.c	clock & (clock_isa | clock_pica) needs-flag

#	Console driver on PC-style graphics
device	pc: tty
attach	pc at pica with pc_pica
attach	pc at isa with pc_isa
device	pms: tty
attach	pms at pica
file	arch/arc/dev/pccons.c		pc & (pc_pica | pc_isa)	needs-flag

#	Serial driver for both ISA and LOCAL bus.
device  ace: tty
attach  ace at isa with ace_isa
attach  ace at commulti with ace_commulti
attach  ace at pica with ace_pica
file    arch/arc/dev/ace.c		ace & (ace_isa | ace_commulti | ace_pica) needs-flag

# 	Parallel ports (XXX what chip?)
device  lpr
attach  lpr at isa with lpr_isa
attach	lpr at pica with lpr_pica
file	arch/arc/dev/lpr.c		lpr & (lpr_isa | lpr_pica) needs-flag

# BusLogic BT-445C VLB SCSI Controller. Special on TYNE local bus.
device  btl: scsi
attach  btl at isa
file    arch/arc/dti/btl.c                    btl needs-count

# National Semiconductor DS8390/WD83C690-based boards
# (WD/SMC 80x3 family, SMC Ultra [8216], 3Com 3C503, NE[12]000, and clones)
# XXX conflicts with other ports; can't be in files.isa
device  ed: ether, ifnet
attach  ed at isa with ed_isa
attach  ed at pcmcia with ed_pcmcia
file    dev/isa/if_ed.c                 ed & (ed_isa | ed_pcmcia) needs-flag

#

file	dev/cons.c
file	dev/cninit.c
file	netinet/in_cksum.c
file	netns/ns_cksum.c			ns

file	compat/ultrix/ultrix_misc.c		compat_ultrix
file	compat/ultrix/ultrix_syscalls.c		compat_ultrix
file	compat/ultrix/ultrix_sysent.c		compat_ultrix


cleaner joinstr

cleaner joinstr

; Matching.  Spun off 29 Jul 06.

; arc> (tostring (writec (coerce 133 'char)))
;
;> (define ss (open-output-string))
;> (write-char (integer->char 133) ss)
;> (get-output-string ss)
;"\u0085"

(def tokens (s (o sep whitec))
  (let test (testify sep)
    (let rec (afn (cs toks tok)
               (if (no cs)         (consif tok toks)
                   (test (car cs)) (self (cdr cs) (consif tok toks) nil)
                                   (self (cdr cs) toks (cons (car cs) tok))))
      (rev (map [coerce _ 'string]
                (map rev (rec (coerce s 'cons) nil nil)))))))

; names of cut, split, halve not optimal

(def halve (s (o sep whitec))
  (let test (testify sep)
    (let rec (afn (cs tok)
               (if (no cs)         (list (rev tok))
                   (test (car cs)) (list cs (rev tok))
                                   (self (cdr cs) (cons (car cs) tok))))
      (rev (map [coerce _ 'string]
                (rec (coerce s 'cons) nil))))))

; maybe promote to arc.arc, but if so include a list clause

(def positions (test seq)
  (accum a
    (let f (testify test)
      (forlen i seq
        (if (f (seq i)) (a i))))))

(def lines (s)
  (accum a
    ((afn ((p . ps))
       (if ps
           (do (a (rem #\return (cut s (+ p 1) (car ps))))
               (self ps))
           (a (cut s (+ p 1)))))
     (cons -1 (positions #\newline s)))))

(def slices (s test)
  (accum a
    ((afn ((p . ps))
       (if ps
           (do (a (cut s (+ p 1) (car ps)))
               (self ps))
           (a (cut s (+ p 1)))))
     (cons -1 (positions test s)))))

; > (require (lib "uri-codec.ss" "net"))
;> (form-urlencoded-decode "x%ce%bbx")
;"xλx"

; first byte: 0-7F, 1 char; c2-df 2; e0-ef 3, f0-f4 4.

; Fixed for utf8 by pc.

(def urldecode (s)
 (tostring
  (forlen i s
    (caselet c (s i)
      #\+ (writec #\space)
      #\% (do (when (> (- (len s) i) 2)
                (writeb (int (cut s (+ i 1) (+ i 3)) 16)))
              (++ i 2))
          (writec c)))))

(def urlencode (s)
  (tostring
    (each c s
      (writec #\%)
      (let i (int c)
        (if (< i 16) (writec #\0))
        (pr (coerce i 'string 16))))))

(mac litmatch (pat string (o start 0))
  (w/uniq (gstring gstart)
    `(with (,gstring ,string ,gstart ,start)
       (unless (> (+ ,gstart ,(len pat)) (len ,gstring))
         (and ,@(let acc nil
                  (forlen i pat
                    (push `(is ,(pat i) (,gstring (+ ,gstart ,i)))
                           acc))
                  (rev acc)))))))

; litmatch would be cleaner if map worked for string and integer args:

;             ,@(map (fn (n c)
;                      `(is ,c (,gstring (+ ,gstart ,n))))
;                    (len pat)
;                    pat)

(mac endmatch (pat string)
  (w/uniq (gstring glen)
    `(withs (,gstring ,string ,glen (len ,gstring))
       (unless (> ,(len pat) (len ,gstring))
         (and ,@(let acc nil
                  (forlen i pat
                    (push `(is ,(pat (- (len pat) 1 i))
                               (,gstring (- ,glen 1 ,i)))
                           acc))
                  (rev acc)))))))

(def posmatch (pat seq (o start 0))
  (catch
    (if (isa pat 'fn)
        (for i start (- (len seq) 1)
          (when (pat (seq i)) (throw i)))
        (for i start (- (len seq) (len pat))
          (when (headmatch pat seq i) (throw i))))
    nil))

(def headmatch (pat seq (o start 0))
  (let p (len pat)
    ((afn (i)
       (or (is i p)
           (and (is (pat i) (seq (+ i start)))
                (self (+ i 1)))))
     0)))

(def begins (seq pat (o start 0))
  (unless (len> pat (- (len seq) start))
    (headmatch pat seq start)))

(def subst (new old seq)
  (let boundary (+ (- (len seq) (len old)) 1)
    (tostring
      (forlen i seq
        (if (and (< i boundary) (headmatch old seq i))
            (do (++ i (- (len old) 1))
                (pr new))
            (pr (seq i)))))))

(def multisubst (pairs seq)
  (tostring
    (forlen i seq
      (iflet (old new) (find [begins seq (car _) i] pairs)
        (do (++ i (- (len old) 1))
            (pr new))
        (pr (seq i))))))

; not a good name

(def findsubseq (pat seq (o start 0))
  (if (< (- (len seq) start) (len pat))
       nil
      (if (headmatch pat seq start)
          start
          (findsubseq pat seq (+ start 1)))))

(def blank (s) (~find ~whitec s))

(def nonblank (s) (unless (blank s) s))

(def trim (s (o where 'both) (o test whitec))
  (withs (f   (testify test)
           p1 (pos ~f s))
    (if p1
        (cut s
             (if (in where 'front 'both) p1 0)
             (when (in where 'end 'both)
               (let i (- (len s) 1)
                 (while (and (> i p1) (f (s i)))
                   (-- i))
                 (+ i 1))))
        "")))

(def num (n (o digits 2) (o trail-zeros nil) (o init-zero nil))
  (withs (comma
          (fn (i)
            (tostring
              (map [apply pr (rev _)]
                   (rev (intersperse '(#\,)
                                     (tuples (rev (coerce (string i) 'cons))
                                             3))))))
          abrep
          (let a (abs n)
            (if (< digits 1)
                 (comma (roundup a))
                (exact a)
                 (string (comma a)
                         (when (and trail-zeros (> digits 0))
                           (string "." (newstring digits #\0))))
                 (withs (d (expt 10 digits)
                         m (/ (roundup (* a d)) d)
                         i (trunc m)
                         r (abs (trunc (- (* m d) (* i d)))))
                   (+ (if (is i 0)
                          (if (or init-zero (is r 0)) "0" "")
                          (comma i))
                      (withs (rest   (string r)
                              padded (+ (newstring (- digits (len rest)) #\0)
                                        rest)
                              final  (if trail-zeros
                                         padded
                                         (trim padded 'end [is _ #\0])))
                        (string (unless (empty final) ".")
                                final)))))))
    (if (and (< n 0) (find [and (digit _) (isnt _ #\0)] abrep))
        (+ "-" abrep)
        abrep)))

(def joinstr (lst (o glue " "))
  (string (intersperse glue lst)))

; by Andrew Wilcox
(def begins-rest (pattern s)
  (if (begins s pattern)
      (cut s (len pattern))))

; English

(def pluralize (n str)
  (if (or (is n 1) (single n))
      str
      (string str "s")))

(def plural (n x)
  (string n #\  (pluralize n x)))

(def capitalize (str)
  (if (blank str) ""
      (+ (upcase (str 0)) (cut str 1))))

(load "help/strings.arc")

; http://www.eki.ee/letter/chardata.cgi?HTML4=1
; http://jrgraphix.net/research/unicode_blocks.php?block=1
; http://home.tiscali.nl/t876506/utf8tbl.html
; http://www.fileformat.info/info/unicode/block/latin_supplement/utf8test.htm
; http://en.wikipedia.org/wiki/Utf-8
; http://unicode.org/charts/charindex2.html

; Matching.  Spun off 29 Jul 06.

; arc> (tostring (writec (coerce 133 'char)))
;
;> (define ss (open-output-string))
;> (write-char (integer->char 133) ss)
;> (get-output-string ss)
;"\u0085"

(def tokens (s (o sep whitec))
  (let test (testify sep)
    (let rec (afn (cs toks tok)
               (if (no cs)         (consif tok toks)
                   (test (car cs)) (self (cdr cs) (consif tok toks) nil)
                                   (self (cdr cs) toks (cons (car cs) tok))))
      (rev (map [coerce _ 'string]
                (map rev (rec (coerce s 'cons) nil nil)))))))

; names of cut, split, halve not optimal

(def halve (s (o sep whitec))
  (let test (testify sep)
    (let rec (afn (cs tok)
               (if (no cs)         (list (rev tok))
                   (test (car cs)) (list cs (rev tok))
                                   (self (cdr cs) (cons (car cs) tok))))
      (rev (map [coerce _ 'string]
                (rec (coerce s 'cons) nil))))))

; maybe promote to arc.arc, but if so include a list clause

(def positions (test seq)
  (accum a
    (let f (testify test)
      (forlen i seq
        (if (f (seq i)) (a i))))))

(def lines (s)
  (accum a
    ((afn ((p . ps))
       (if ps
           (do (a (rem #\return (cut s (+ p 1) (car ps))))
               (self ps))
           (a (cut s (+ p 1)))))
     (cons -1 (positions #\newline s)))))

(def slices (s test)
  (accum a
    ((afn ((p . ps))
       (if ps
           (do (a (cut s (+ p 1) (car ps)))
               (self ps))
           (a (cut s (+ p 1)))))
     (cons -1 (positions test s)))))

; > (require (lib "uri-codec.ss" "net"))
;> (form-urlencoded-decode "x%ce%bbx")
;"xλx"

; first byte: 0-7F, 1 char; c2-df 2; e0-ef 3, f0-f4 4.

; Fixed for utf8 by pc.

(def urldecode (s)
 (tostring
  (forlen i s
    (caselet c (s i)
      #\+ (writec #\space)
      #\% (do (when (> (- (len s) i) 2)
                (writeb (int (cut s (+ i 1) (+ i 3)) 16)))
              (++ i 2))
          (writec c)))))

(def urlencode (s)
  (tostring
    (each c s
      (writec #\%)
      (let i (int c)
        (if (< i 16) (writec #\0))
        (pr (coerce i 'string 16))))))

(mac litmatch (pat string (o start 0))
  (w/uniq (gstring gstart)
    `(with (,gstring ,string ,gstart ,start)
       (unless (> (+ ,gstart ,(len pat)) (len ,gstring))
         (and ,@(let acc nil
                  (forlen i pat
                    (push `(is ,(pat i) (,gstring (+ ,gstart ,i)))
                           acc))
                  (rev acc)))))))

; litmatch would be cleaner if map worked for string and integer args:

;             ,@(map (fn (n c)
;                      `(is ,c (,gstring (+ ,gstart ,n))))
;                    (len pat)
;                    pat)

(mac endmatch (pat string)
  (w/uniq (gstring glen)
    `(withs (,gstring ,string ,glen (len ,gstring))
       (unless (> ,(len pat) (len ,gstring))
         (and ,@(let acc nil
                  (forlen i pat
                    (push `(is ,(pat (- (len pat) 1 i))
                               (,gstring (- ,glen 1 ,i)))
                           acc))
                  (rev acc)))))))

(def posmatch (pat seq (o start 0))
  (catch
    (if (isa pat 'fn)
        (for i start (- (len seq) 1)
          (when (pat (seq i)) (throw i)))
        (for i start (- (len seq) (len pat))
          (when (headmatch pat seq i) (throw i))))
    nil))

(def headmatch (pat seq (o start 0))
  (let p (len pat)
    ((afn (i)
       (or (is i p)
           (and (is (pat i) (seq (+ i start)))
                (self (+ i 1)))))
     0)))

(def begins (seq pat (o start 0))
  (unless (len> pat (- (len seq) start))
    (headmatch pat seq start)))

(def subst (new old seq)
  (let boundary (+ (- (len seq) (len old)) 1)
    (tostring
      (forlen i seq
        (if (and (< i boundary) (headmatch old seq i))
            (do (++ i (- (len old) 1))
                (pr new))
            (pr (seq i)))))))

(def multisubst (pairs seq)
  (tostring
    (forlen i seq
      (iflet (old new) (find [begins seq (car _) i] pairs)
        (do (++ i (- (len old) 1))
            (pr new))
        (pr (seq i))))))

; not a good name

(def findsubseq (pat seq (o start 0))
  (if (< (- (len seq) start) (len pat))
       nil
      (if (headmatch pat seq start)
          start
          (findsubseq pat seq (+ start 1)))))

(def blank (s) (~find ~whitec s))

(def nonblank (s) (unless (blank s) s))

(def trim (s (o where 'both) (o test whitec))
  (withs (f   (testify test)
           p1 (pos ~f s))
    (if p1
        (cut s
             (if (in where 'front 'both) p1 0)
             (when (in where 'end 'both)
               (let i (- (len s) 1)
                 (while (and (> i p1) (f (s i)))
                   (-- i))
                 (+ i 1))))
        "")))

(def num (n (o digits 2) (o trail-zeros nil) (o init-zero nil))
  (withs (comma
          (fn (i)
            (tostring
              (map [apply pr (rev _)]
                   (rev (intersperse '(#\,)
                                     (tuples (rev (coerce (string i) 'cons))
                                             3))))))
          abrep
          (let a (abs n)
            (if (< digits 1)
                 (comma (roundup a))
                (exact a)
                 (string (comma a)
                         (when (and trail-zeros (> digits 0))
                           (string "." (newstring digits #\0))))
                 (withs (d (expt 10 digits)
                         m (/ (roundup (* a d)) d)
                         i (trunc m)
                         r (abs (trunc (- (* m d) (* i d)))))
                   (+ (if (is i 0)
                          (if (or init-zero (is r 0)) "0" "")
                          (comma i))
                      (withs (rest   (string r)
                              padded (+ (newstring (- digits (len rest)) #\0)
                                        rest)
                              final  (if trail-zeros
                                         padded
                                         (trim padded 'end [is _ #\0])))
                        (string (unless (empty final) ".")
                                final)))))))
    (if (and (< n 0) (find [and (digit _) (isnt _ #\0)] abrep))
        (+ "-" abrep)
        abrep)))

(def cat lst
  (reduce + (map string lst)))

(def joinstr (lst (o glue " "))
  (let lst (keep [len> _ 0] lst)
    (if lst
      (apply + (intersperse (string glue) lst))
      "")))

; by Andrew Wilcox
(def begins-rest (pattern s)
  (if (begins s pattern)
      (cut s (len pattern))))

; English

(def pluralize (n str)
  (if (or (is n 1) (single n))
      str
      (string str "s")))

(def plural (n x)
  (string n #\  (pluralize n x)))

(def capitalize (str)
  (if (blank str) ""
      (+ (upcase (str 0)) (cut str 1))))

(load "help/strings.arc")

; http://www.eki.ee/letter/chardata.cgi?HTML4=1
; http://jrgraphix.net/research/unicode_blocks.php?block=1
; http://home.tiscali.nl/t876506/utf8tbl.html
; http://www.fileformat.info/info/unicode/block/latin_supplement/utf8test.htm
; http://en.wikipedia.org/wiki/Utf-8
; http://unicode.org/charts/charindex2.html


Added "zeros", "ones" and "randmat" as basic building blocks for more complex matrix/list functions.

(require "lib/util.arc")
(require "lib/math.arc")
(require "lib/extend.arc")

; statistics. 10 Oct 2010.
; Ali Moeeny

; experimenting with matrices
; quit possibly these turn out to be redundant but I need to do it until I find out what the best way to do it is.

; gives a 1D or 2D matrix/list of zeros

(def zeros (x (o y))
  (if y (map zeros (map (fn (_) (+ _ x)) (zeros y)))
      (map (fn (_) (= _ 0)) (range 1 x))))

; gives a 1D or 2D matrix/list of ones

(def ones (x (o y))
  (if y (map ones (map (fn (_) (+ _ x)) (zeros y)))
      (map (fn (_) (= _ 1)) (range 1 x))))

; gives a 1D or 2D matrix/list of random numbers

(def randmat (x (o y))
  (if y (map randmat (map (fn (_) (+ _ x)) (zeros y)))
    (map (fn (_) (= _ (rand))) (range 1 x))))

(def diffsquared (x y)
     		 (apply + (map [* (- _ y)(- _ y)] x)))

(def sumsquared (x y)
     	   (apply + (map * x y)))

(def sumdiffmultiplied (x y)
       (with (mx (avg x) my (avg y))
       (reduce +
       	       (map *
	       	    (map [- _ mx] x)
		    (map [- _ my] y)))))

(def pearsonscorrelation (x y)
     (/ (sumdiffmultiplied x y)
        (sqrt
	      (*
	      	 (diffsquared
		 	 x
			 (avg x))
	         (diffsquared y
		 	 (avg y)))))
)

; Mark Huetsch

; Some simple matrix stuff I wrote. Would probably be better if matrix were its own type, like a hash table, so that things like + and - could
; be used in lieu of +m and -m, and ij could be eliminated, but this was just thrown together when I needed a nearest neighbors alg.

(def pm (m)
  (each r m (prn r)))

(def +v vs
  (map [reduce + _] (apply zip vs)))

(def -v vs
  (map [reduce - _] (apply zip vs)))

(def *v (a b)
  (if (isa a 'int)
      (map [* a _] b)
      (map [* b _] a)))

(def lenv (v)
  (sqrt (reduce + (map square v))))

(def dot (a b)
  (reduce + (map [apply * _] (zip a b))))

(def cosv (a b)
  (/ (dot a b) (* (lenv a) (lenv b))))

(def cosm (m)
  (mapeach row1 m
	   (map [cosv _ row1] m)))

(def pearson (x y)
  (with (xbar (avg x) ybar (avg y))
    (/ (reduce + (map (fn (xi yi) (* (- xi xbar) (- yi ybar))) x y))
       (sqrt (* (reduce + (map [square (- _ xbar)] x))
		(reduce + (map [square (- _ ybar)] y)))))))

(def pearsonm (m)
  (mapeach row1 m
	   (map [pearson _ row1] m)))

(def rows (m) m)

(def cols (m)
  (apply zip m))

(def tm (m)
  (cols m))

(def +m ms
  (map [apply +v _] (apply zip ms)))

(def -m ms
  (map [apply -v _] (apply zip ms)))

(def ij (m i j)
  ((m i) j))

(mac sij (m i j v)
  (w/uniq modified-row
    `(= ,m
	(let ,modified-row (,m ,i)
	  (+ (cut ,m 0 ,i)
	     (list (+ (cut ,modified-row 0 ,j) (list ,v) (cut ,modified-row (+ 1 ,j))))
	     (cut ,m (+ 1 ,i)))))))

(def bestnpos (n f seq)
  (with (vals (bestn n f seq) indices nil last-val nil last-pos 0)
    (each val vals
      (let found-pos (pos val seq (if (is val last-val) (+ 1 last-pos) 0))
	(push found-pos indices)
	(= last-val val)
	(= last-pos found-pos)))
    (rev indices)))

(def weighted-nearest-neighbors (v m (o n 10))
  (let pearm (pearsonm (+ m (list v)))
    (mapeach vec-pos (bestnpos n > (butlast (last pearm)))
	     (list (m vec-pos) ((butlast (last pearm)) vec-pos)))))

; maybe base this off of a weighted-nearest-neighbors? and allow to choose similarity function
(def nearest-neighbors (v m (o n 10))
  (let pearm (pearsonm (+ m (list v)))
    (mapeach vec-pos (bestnpos n > (butlast (last pearm)))
	     (m vec-pos))))

(def vec lst
  (annotate 'vector lst))

(extend + args (all [isa _ 'vector] args)
        (apply +v (map rep args)))

(extend - args (all [isa _ 'vector] args)
        (apply -v (map rep args)))

 (defcall vector (vec i)
    rep.vec.i)

; This manner of setting inspired by lush. I like it because it saves a lot of typing if you're constantly modifying vectors.
 (defcall vector (vec i val)
    (= rep.vec.i val))

(require "lib/util.arc")
(require "lib/math.arc")
(require "lib/extend.arc")

; statistics. 06 Oct 2010.

; Ali Moeeny

(def diffSquared (x y)
     		 (apply + (map [* (- _ y)(- _ y)] x)))

(def sumSquared (x y)
     	   (apply + (map * x y)))

(def sumDiffMultiplied (x y)
       (with (mx (avg x) my (avg y))
       (reduce +
       	       (map *
	       	    (map [- _ mx] x)
		    (map [- _ my] y)))))

(def pearsonsCorrelation (x y)
     (/ (sumDiffMultiplied x y)
        (sqrt
	      (*
	      	 (diffSquared
		 	 x
			 (avg x))
	         (diffSquared y
		 	 (avg y)))))
)

; Mark Huetsch

; Some simple matrix stuff I wrote. Would probably be better if matrix were its own type, like a hash table, so that things like + and - could
; be used in lieu of +m and -m, and ij could be eliminated, but this was just thrown together when I needed a nearest neighbors alg.

(def pm (m)
  (each r m (prn r)))

(def +v vs
  (map [reduce + _] (apply zip vs)))

(def -v vs
  (map [reduce - _] (apply zip vs)))

(def *v (a b)
  (if (isa a 'int)
      (map [* a _] b)
      (map [* b _] a)))

(def lenv (v)
  (sqrt (reduce + (map square v))))

(def dot (a b)
  (reduce + (map [apply * _] (zip a b))))

(def cosv (a b)
  (/ (dot a b) (* (lenv a) (lenv b))))

(def cosm (m)
  (mapeach row1 m
	   (map [cosv _ row1] m)))

(def pearson (x y)
  (with (xbar (avg x) ybar (avg y))
    (/ (reduce + (map (fn (xi yi) (* (- xi xbar) (- yi ybar))) x y))
       (sqrt (* (reduce + (map [square (- _ xbar)] x))
		(reduce + (map [square (- _ ybar)] y)))))))

(def pearsonm (m)
  (mapeach row1 m
	   (map [pearson _ row1] m)))

(def rows (m) m)

(def cols (m)
  (apply zip m))

(def tm (m)
  (cols m))

(def +m ms
  (map [apply +v _] (apply zip ms)))

(def -m ms
  (map [apply -v _] (apply zip ms)))

(def ij (m i j)
  ((m i) j))

(mac sij (m i j v)
  (w/uniq modified-row
    `(= ,m
	(let ,modified-row (,m ,i)
	  (+ (cut ,m 0 ,i)
	     (list (+ (cut ,modified-row 0 ,j) (list ,v) (cut ,modified-row (+ 1 ,j))))
	     (cut ,m (+ 1 ,i)))))))

(def bestnpos (n f seq)
  (with (vals (bestn n f seq) indices nil last-val nil last-pos 0)
    (each val vals
      (let found-pos (pos val seq (if (is val last-val) (+ 1 last-pos) 0))
	(push found-pos indices)
	(= last-val val)
	(= last-pos found-pos)))
    (rev indices)))

(def weighted-nearest-neighbors (v m (o n 10))
  (let pearm (pearsonm (+ m (list v)))
    (mapeach vec-pos (bestnpos n > (butlast (last pearm)))
	     (list (m vec-pos) ((butlast (last pearm)) vec-pos)))))

; maybe base this off of a weighted-nearest-neighbors? and allow to choose similarity function
(def nearest-neighbors (v m (o n 10))
  (let pearm (pearsonm (+ m (list v)))
    (mapeach vec-pos (bestnpos n > (butlast (last pearm)))
	     (m vec-pos))))

(def vec lst
  (annotate 'vector lst))

(extend + args (all [isa _ 'vector] args)
        (apply +v (map rep args)))

(extend - args (all [isa _ 'vector] args)
        (apply -v (map rep args)))

 (defcall vector (vec i)
    rep.vec.i)

; This manner of setting inspired by lush. I like it because it saves a lot of typing if you're constantly modifying vectors.
 (defcall vector (vec i val)
    (= rep.vec.i val))