hacks

(tidier examples of) random scripts from throughout the years
Log | Files | Refs | README

regex.lisp (3061B)

      1 ;; Editor's note: Experiments with Coalton and the paper "A Play on Regular Expressions"
      2 ;; by Sebastian Fischer, Frank Huch, and Thomas Wilke.
      3 ;; Written around the summer of 2024.
      4 
      5 (ql:quickload :coalton)
      6 
      7 (defpackage #:regex-play
      8   (:use 
      9    #:coalton
     10    #:coalton-prelude)
     11   (:local-nicknames 
     12    (#:str #:coalton-library/string)
     13    (#:list #:coalton-library/list)
     14    (#:iter #:coalton-library/iterator)))
     15 
     16 (in-package #:regex-play)
     17 
     18 (coalton-toplevel    
     19   (declare explode ((String -> (List Char))))
     20   (define (explode s) (iter:collect! (str:chars s)))
     21   
     22   (declare splits ((List :a) -> (List (Tuple (List :a) (List :a)))))
     23   (define (splits l)
     24     (match l
     25       ((Nil) (singleton (tuple nil nil)))
     26       ((Cons c cs)
     27        (cons (tuple nil (cons c cs))
     28 	     (map (fn ((Tuple s1 s2)) (tuple (cons c s1) s2)) (splits cs))))))
     29 
     30   (declare parts ((List :a) -> (List (List (List :a)))))
     31   (define (parts l)
     32     (match l
     33       ((Nil) (singleton nil))
     34       ((Cons c nil) (singleton (singleton (singleton c))))
     35       ((Cons c cs)
     36        (let ((f (fn (part) (match part ((Nil) nil)
     37 			     ((Cons p ps) (make-list (cons (cons c p) ps) (cons (singleton c) part)))))))
     38 	 (list:concat (map f (parts cs)))))))
     39 
     40   (define-class (Semiring :s)
     41     (zero :s)
     42     (one :s)
     43     (plus (:s -> :s -> :s))
     44     (times (:s -> :s -> :s)))
     45 
     46   (declare rsum ((Semiring :s) => ((List :s) -> :s)))
     47   (define (rsum l) (foldr plus zero l))
     48 
     49   (declare rprod ((Semiring :s) => ((List :s) -> :s)))
     50   (define (rprod l) (foldr times one l))
     51   
     52   (define-type Reg
     53     (REps)
     54     (RSym Char)
     55     (RAlt Reg Reg)
     56     (RSeq Reg Reg)
     57     (RRep Reg))
     58   
     59   (define-type (WReg :c :s)
     60     (WEps)
     61     (WSym (:c -> :s))
     62     (WAlt (WReg :c :s) (WReg :c :s))
     63     (WSeq (WReg :c :s) (WReg :c :s))
     64     (WRep (WReg :c :s)))
     65 
     66   (declare sym ((Semiring :s) => (Char -> (WReg Char :s))))
     67   (define (sym c) (WSym (fn (x) (if (== x c) one zero))))
     68 
     69   (declare weighted ((Semiring :s) => (Reg -> (WReg Char :s))))
     70   (define (weighted r)
     71     (match r
     72       ((REps) WEps)
     73       ((RSym c) (sym c))
     74       ((RAlt p q) (WAlt (weighted p) (weighted q)))
     75       ((RSeq p q) (WSeq (weighted p) (weighted q)))
     76       ((RRep r) (WRep (weighted r)))))
     77   
     78   (declare accept ((Semiring :s) => ((WReg :c :s) -> (List :c) -> :s)))
     79   (define (accept r u)
     80     (match r
     81       ((WEps) (if (== (length u) 0) one zero))
     82       ((WSym f) (match u ((Cons c nil) (f c)) (_ zero)))
     83       ((WAlt p q) (plus (accept p u) (accept q u)))
     84       ((WSeq p q) (rsum (map (fn ((Tuple u1 u2)) (times (accept p u1) (accept q u2))) (splits u))))
     85       ((WRep r) (rsum (map (compose rprod (map (accept r))) (parts u))))))
     86 
     87   (define-instance (Semiring Boolean)
     88     (define zero False)
     89     (define one True)
     90     (define (plus x y) (or x y))
     91     (define (times x y) (and x y)))
     92 
     93   (define-instance (Semiring Integer)
     94     (define zero 0)
     95     (define one 1)
     96     (define (plus x y) (+ x y))
     97     (define (times x y) (* x y))))
     98   
     99 (coalton
    100   (let ((as (RAlt (RSym #\a) (RRep (RSym #\a)))))        
    101     (the Integer (accept (weighted as) (explode "aaa")))))