#lang racket/base
(provide (all-defined-out))
(define-values (prop:setter
prop:setter?
prop:setter-accessor)
(make-struct-type-property 'prop:setter))
(struct str (v)
#:transparent
#:property prop:procedure
(case-lambda
[(a-str index)
(string-ref (str-v a-str) index)]
[(a-str index v)
(string-set! (str-v a-str) index v)])
#:property prop:custom-write
(lambda (a-str port mode)
(let ([recur (case mode
[(#t)
(lambda (p port)
(write p port))]
[(#f)
(lambda (p port)
(display p port))]
[else
(lambda (p port)
(print p port mode))])])
(recur (str-v a-str) port)))
#:property prop:setter
(lambda (a-str index v)
(string-set! (str-v a-str) index v)))
(struct arc-cons (h t)
#:transparent
#:mutable
#:property prop:custom-write
(lambda (p port mode)
(case mode
[(#t)
(cond
[(arc-list? p)
(write (arc-list->list p) port)]
[else
(write (cons (arc-cons-h p) (arc-cons-t p))
port)])]
[(#f)
(cond
[(arc-list? p)
(display (arc-list->list p) port)]
[else
(display (cons (arc-cons-h p) (arc-cons-t p))
port)])]
[else
(cond
[(arc-list? p)
(print (arc-list->list p) port mode)]
[else
(print (cons (arc-cons-h p) (arc-cons-t p))
port
mode)])])))
(struct Arc-car ()
#:property prop:procedure
(lambda (self v)
(arc-cons-h v))
#:property prop:setter
(lambda (self a-pair v)
(set-arc-cons-h! a-pair v)))
(define arc-car (Arc-car))
(struct Arc-cdr ()
#:property prop:procedure
(lambda (self v)
(arc-cons-t v))
#:property prop:setter
(lambda (self a-pair v)
(set-arc-cons-t! a-pair v)))
(define arc-cdr (Arc-cdr))
(struct arc-t ()
#:transparent
#:property prop:custom-write
(lambda (_ port mode)
(case mode
[(#t) (display "t" port)]
[(#f) (display "t" port)]
[else (display "t" port)])))
(struct arc-nil ()
#:transparent
#:property prop:custom-write
(lambda (_ port mode)
(case mode
[(#t) (display 'nil port)]
[(#f) (display 'nil port)]
[else (display 'nil port)])))
(define t (arc-t))
(define nil (arc-nil))
(define (arc-list . args)
(list->arc-list args))
(define (arc-list? x)
(define ht (make-hasheq))
(let loop ([x x])
(cond [(eq? x nil) #t]
[(arc-cons? x)
(cond [(hash-has-key? ht x)
#f]
[else
(hash-set! ht x #t)
(loop (arc-cons-t x))])])))
(define (list->arc-list lst)
(cond
[(null? lst)
nil]
[else
(arc-cons (car lst)
(list->arc-list (cdr lst)))]))
(define (arc-list->list lst)
(cond
[(eq? lst nil)
'()]
[else
(cons (arc-cons-h lst)
(arc-list->list (arc-cons-t lst)))]))
(define-syntax-rule (arc-true? x)
(not (eq? x nil)))
(define-syntax-rule (arc-false? x)
(eq? x nil))
(define (arc-is x y)
(adapt/bool (arc-is? x y)))
(define (arc-iso x y)
(adapt/bool (equal? x y)))
(define-syntax-rule (adapt/bool x)
(if x t nil))
(define (arc-no x)
(if (arc-true? x)
nil
t))
(define (arc-odd x)
(adapt/bool (odd? x)))
(define (arc-even x)
(adapt/bool (even? x)))
(define (arc-compose f g)
(lambda (x)
(f (g x))))
(define (arc-negate f)
(lambda (x)
(if (arc-true? (f x))
nil
t)))
(define (arc-is? x y)
(if (and (str? x) (str? y))
(string=? (str-v x) (str-v y))
(eq? x y)))
(define (arc-map f l)
(cond
[(eq? l nil)
nil]
[else
(arc-cons (f (arc-car l))
(arc-map f (arc-cdr l)))]))