added

diff --git a/arper.lsp b/arper.lsp
new file mode 100755 (executable)
index 0000000..caf763d
--- /dev/null
+++ b/arper.lsp
@@ -0,0 +1,193 @@
+#!/usr/local/bin/newlisp
+# Copyright 2017, Ralph Ronnquist <ralph.ronnquist@gmail.com>
+
+;; This program iplements arp responding for selected IP and
+;; interfaces. It listens to network traffic on a given tap, then
+;; responds to any arp requests as per its configuration.
+;;
+;; Usage: -t <tap> <conf>
+;; where <tap> is the tap to service, and <conf> is the pathname for
+;; the configuration file.
+;;
+;; The configuration file has lines of "IP MAC whatever"; other lines
+;; are ignored (as comments).
+
+# Exit on INT, i.e., ^C
+(signal 2 (fn (x) (exit 0)))
+
+# The following library path is for Devuan GNU+Linux
+(constant 'LIBC "/lib/x86_64-linux-gnu/libc.so.6")
+(import LIBC "ioctl" "int" "int" "long" "void*" )
+(import LIBC "perror" "void" "char*" )
+(import LIBC "ntohs" "int" "int" )
+(import LIBC "htons" "int" "int" )
+
+# Report low level system error and exit
+(define (die s) (perror s) (exit 1))
+
+# Tell about usage and exit with error.
+(define (usage)
+  (write-line 2 [text];; Usage: -t <tap> <conf>
+;; where <tap> is the tap to service, and <conf> is the pathnmae fore
+;; the configuration file.
+[/text]
+   )
+  (exit 1))
+
+# Pick up tap name and handled IP from the command line, open
+# the "tun" device (Devuan GNU+Linux), and initialize it for using the
+# given tap name as a tap (not a tun), without packet wrapping.
+(constant 'CMDARG (if (match '(* "-t" ? ?) (main-args)) (1 $it) nil))
+(when (null? CMDARG) (usage))
+
+(constant
+ 'IFNAME (CMDARG 0)
+ 'IFD (open "/dev/net/tun" "u")
+ )
+
+(unless (number? IFD)
+  (die "open"))
+(unless (zero? (ioctl IFD 0x400454ca (pack "s16 u s22" IFNAME 0x1002 "")))
+  (die (string "set " IFNAME)))
+
+# Set up the IP map
+(define MAP:MAP nil)
+(define (decimal x) (int x 0 10))
+(define (hexadecimal x) (int x 0 16))
+(dolist (X (parse (read-file (CMDARG 1)) "\n"))
+  (when (regex "^\s*([0-9\.]+)\\s+([0-9a-fA-F:]+)" X 0)
+    (let ((IP $1) (MAC $2))
+      (MAP (string (map decimal (parse IP ".")))
+           (map hexadecimal (parse MAC ":")))
+      )))
+
+# Pack a pair og bytes into a 16-bit number
+(define (b2u x) (+ (<< (x 0) 8) (x 1)))
+
+# Unpack a short number into two bytes in network order
+(define (stonb x) (list (& 0xFF (>> x 8)) (& 0xFF x)))
+
+# Unpack a 32-bit number into two 16-bit in network order
+(define (n2u x) (list (& 0xFFFF (>> x 16)) (& 0xFFFF x)))
+
+# Compute 16 bit checksum of a small even number of bytes
+(define (checksum bytes)
+  (apply + (n2u (- (apply + (map b2u (explode bytes 2)))))))
+
+# Pack a byte sequence into a string
+(define (pack-bytes bytes) (pack (dup "b" (length bytes)) bytes))
+
+# Join IP address bytes into a dotted quad string.
+(define (pack-ip x) (join (map string x) "."))
+
+# Process an IPv4 header byte sequence without checksum by inserting one.
+(define (ipv4-header-checksum h)
+  (flat (list (0 10 h) (stonb (checksum h)) (10 h))))
+
+# Process an ICMP header byte sequence without checksum by inserting one.
+(define (icmp-header-checksum t c tail)
+  (let ((data (unpack (dup "b" (length tail)) tail)))
+    (flat (list t c (stonb (checksum (flat (list t c data)))) data))))
+
+# ARP request handler. Confirms the targeted IP address is one to
+# handle and then issues a corresponding reply. Note: the MAC address
+# is formed from the IP address.
+(define (arp-request-handler) ; buffer
+  (letn ((IP (unpack "bbbb" (38 buffer)))
+         (MYMAC (flat (list 2 IP 2)))
+         (MAPMAC (MAP (string IP))))
+    (when MAPMAC
+      (write IFD (pack "bbbbbb bbbbbb u u u b b u bbbbbb bbbb bbbbbb bbbb"
+                        (flat (list (unpack "bbbbbb" (6 buffer))
+                                    MYMAC (map htons '(0x0806 0x1 0x0800 ))
+                                    0x06 0x04 (htons 0x2) MAPMAC IP
+                                    (unpack "bbbbbb bbbb" (22 buffer))
+                                    ))
+                        )))))
+
+# ARP packet handler. Recognizes the ARP command involved, and for
+# some of them, it dispatches to the associated handler, if any.
+(define (arp-handler) ; buffer
+  (case (ntohs ((unpack "u" (20 buffer)) 0)) ; ARP command
+    (0x0001 (and arp-request-handler (arp-request-handler)))
+    (true nil) ; ignore
+    ))
+
+# ICMP request handler. Confirms that the targeted IP is one to
+# handle, and then issues a corresponding response.
+(define (icmp-request-handler)
+  (letn ((h (unpack "bbbb bbbb" (26 buffer)))
+         (n (ntohs((unpack "u" (16 buffer)) 0))))
+    (println "ICMP request " (pack-ip (0 4 h)) " --> " (pack-ip (4 4 h)))
+    (when (member (4 4 h) MYIPS)
+      (write IFD
+             (pack-bytes
+              (flat (list
+                     # Ethernet header (14 bytes)
+                     (unpack "bbbbbb" (6 buffer))
+                     2 (4 4 h) 2
+                     (stonb 0x0800) ; Type = IPv4
+                     # IPv4 header (20 bytes, with header checksum)
+                     (ipv4-header-checksum
+                      (flat (list 0x45 0 0 n
+                                  (unpack "bbbbbb" (18 buffer))
+                                  (4 4 h) (0 4 h))))
+                     # ICMP header
+                     (icmp-header-checksum 0 0 ((+ ihl 18) buffer))
+                     ))
+              ))
+      )))
+
+# ICMP packet handler. Recognizes the ICMP type involved and for some
+# of them, it dispatches to the associated handler, if any.
+(define (icmp-handler)
+  (case ((unpack "b" ((+ ihl 14) buffer)) 0)
+    (8 (and icmp-request-handler (icmp-request-handler)))
+    (true)))
+
+# IPv4 packet handler. Recognises the IPv4 protocol involved, and for
+# some of them, it dispatches to the associated handler, if any.
+(define (ipv4-handler) ; buffer
+  (let ((ihl (* (& 0x0F ((unpack "b" (14 buffer)) 0)) 4)))
+    (case ((unpack "b" (23 buffer)) 0) ; protocol
+      (0x01 (and icmp-handler (icmp-handler)))
+      (0x02 (and igmp-handler (igmp-handler)))
+      (0x04 (and ipip-handler (ipip-handler)))
+      (0x06 (and tcp-handler (tcp-handler)))
+      (0x11 (and udp-handler (udp-handler)))
+      (true nil) ; ignore
+      )
+    ))
+
+# Ethernet packet handler. Recognises EtherTYpe involved, and for some
+# of them, it dispatches to the associated handler, if any.
+(define (handle-packet) ; buffer
+  (when (> n 14)
+    (case (ntohs ((unpack "u" (12 buffer)) 0)) ; Ethertype
+      (0x0806 (and arp-handler (arp-handler)))
+      ;(0x0800 (and ipv4-handler (ipv4-handler)))
+      ;(0x86DD (and ipv6-handler (ipv6-handler)))
+      (true nil) ; ignore all else
+      )))
+
+# Tap handler. Reads an Ethernet packet from the tap, and invokes the
+# associated handler.
+(define (handle-tap)
+  (let ((buffer "") (n nil))
+    (if (setf n (read IFD buffer 8000)) (handle-packet)
+      (die (string "** error reading " IFNAME)))))
+
+# Input handler. Waits for input on the tap or stdin, and invokes the
+# associated handler. This is set up as a prompt-event handler, so as
+# to multiplex tap handling with newlisp interactive command handling.
+(define (ioselect s)
+  (letn ((fds (list 0 IFD)) (fdx nil))
+    (until (member 0 (setf fdx (or (net-select fds "r" 10000000) '())))
+      (when fdx (handle-tap))))
+  nil)
+
+# "Main program" starts here
+(println "IP addresses on " IFNAME ":")
+(map println (MAP))
+(prompt-event ioselect)
+(reset)

diff --git a/phrasehit.lsp b/phrasehit.lsp
new file mode 100644 (file)
index 0000000..dd771c4
--- /dev/null
+++ b/phrasehit.lsp
@@ -0,0 +1,77 @@
+# This script must be embedded for the arguments to work
+# $0 = this program
+# $1 = file to review
+# $2 = phrase to find
+
+# Read "file" document, compute and print its least match penalty for
+# the given phrase
+
+;(reader-event (fn (x) (write-line (string x)) x))
+
+# Map a UTF8 text into its bigram sequence
+(define (bigrams TEXT)
+  (let ((i -1) (N (utf8len TEXT)))
+    (map (fn (s) (replace "([?.*])" s (string "\\" $1) 0))
+         (clean (fn (x) (< (length x) 2))
+                (collect (when (< (inc i) N) (i 2 TEXT)))))))
+
+# Replace newlines and successions of spaces with single spaces
+(define (read-text FILE)
+  (replace "\\s\\s+" (replace "\n" (read-file FILE) " " 0) " " 0))
+
+; Determine the placements for bigram P in DATA after index i. This
+; returns the placment options in ascending order.
+(define (indexes P DATA (i -1))
+  (collect (setf i (find P DATA 1 (inc i)))))
+
+; Find the first of IL placement lists after i, prepend i to that and
+; return. Returns nil if all IL starts at or before i. This is used
+; for finding the "best" placement for an antecedent bigram at i, wrt
+; the alternative successor bigram "best" placements.
+(define (last-before i IL)
+  (if (find i IL (fn (x y) (< x (y 0)))) (cons i (IL $it)) (list i)))
+
+; Combine the placement options PL of bigram P relative to best
+; placements options of successor bigrams IL. This appends each
+; placement option to its "best" successor placement list. The choice
+; of dropping this bigram also yields all IL successor placements
+; options. The resulting placment options is sorted by ascending first
+; placement.
+(define (combine P PL IL)
+  (if (null? PL) IL IL
+      (sort (append (map (fn (i) (last-before i IL)) PL) IL))
+      (map list PL)))
+
+; Process the bigrams PL to be placed into the text DATA. Returns a
+; list of placement lists to indicate alternative ways of placing the
+; given bigrams.
+(define (chicks PL DATA)
+  (if (null? PL) (list)
+    (combine (PL 0) (indexes (PL 0) DATA) (chicks (1 PL) DATA))))
+
+; Compute the "gap sum" for the given placement list, which tells how
+; much bigrams are separated from each other in the placement list.
+; Returns a triplet of 1) the number of discarded bigrams, 2) the
+; accumulated separation count and 3) a placment description of where
+; and which bigrams are placed.
+(define (gapsum L)
+  (let ((N (- (length PHRASE) (length L))))
+    (list N (- (apply + (map - L (cons (L 0) L))) (length L) -1))))
+
+;;; Load arguments
+(setf
+ PHRASE (bigrams (main-args 1))
+ CLIP (/ (* 45 (length PHRASE)) 100) 
+ )
+
+(dolist (FILE (2 (main-args)))
+  (when (file? FILE)
+    (setf LINES '() COUNT 0)
+    (dolist (DATA (parse (read-file FILE) "\n"))
+      (let ((BEST (if (sort (map gapsum (chicks PHRASE DATA))) (first $it))))
+        (inc COUNT)
+        (when (and BEST (< (BEST 0) CLIP))
+          (push (list (append BEST (list COUNT)) DATA) LINES -1))))
+    (map (fn (x) (println FILE ":" (x -1))) (sort LINES))))
+
+(exit 0)