Welcome to the CHICKEN Scheme pasting service
long compilation time ? added by jcob on Tue Nov 14 15:19:19 2017
;; This creates a lewis structure object with slots for top, bot, left, right, and center
(require-extension coops)
(require-extension srfi-13)
(require-extension irregex)
(use parley)
(define-class element-some-base ()
((element-name reader: get-element-name)
(number-of-dots reader: get-number-of-dots)))
;; Getting from number-of-dots to the position of the dots
(define (number->tlist n)
(let n-to-tlist ((counter n) (l '()))
(if (= counter 0)
l
(n-to-tlist (- counter 1) (cons #t l)))))
(define (number->flist n)
(let n-to-flist ((counter n) (l '()))
(if (= counter 0)
l
(n-to-flist (- counter 1) (cons #f l)))))
(define (number->clockwise-boolean-list n)
(cond
((> n 4)
(flatten (zip (number->tlist 4) (append (number->tlist (- n 4)) (number->flist (- 8 n))))))
((= n 4)
(flatten (zip (number->tlist 4) (number->flist 4))))
((< n 4)
(flatten (zip (append (number->tlist n) (number->flist (- 4 n))) (number->flist 4))))))
(define (group-in-pairs lst)
(reverse
(let g-i-p ((l lst) (acc '()))
(if (null? l)
acc
(g-i-p (cddr l) (cons (list (car l) (cadr l)) acc))))))
(define-class element-some ()
((element-some-base reader: get-element-some-base)
(etop reader: get-etop)
(elef reader: get-elef)
(erig reader: get-erig)
(ebot reader: get-ebot)))
(define-method (get-element-name (obj element-some))
(get-element-name (get-element-some-base obj)))
(define-method (get-number-of-dots (obj element-some))
(get-number-of-dots (get-element-some-base obj)))
(define (make-element-some-base e-n n-d)
(make element-some-base 'element-name e-n 'number-of-dots n-d))
(define (decorate-element-some-base e-some-base)
(let ((epairs (group-in-pairs
(number->clockwise-boolean-list
(get-number-of-dots e-some-base)))))
(make element-some 'element-some-base e-some-base 'etop (car epairs) 'erig (cadr epairs) 'ebot (caddr epairs) 'elef (cadddr epairs))))
(define (make-element-some element-name number-of-dots)
(decorate-element-some-base (make element-some-base 'element-name element-name 'number-of-dots number-of-dots)))
(define-class element-ligand ()
((element-some reader: get-element-some)
(nbonds reader: get-nbonds)))
(define-method (get-etop (obj element-ligand))
(get-etop (get-element-some obj)))
(define-method (get-ebot (obj element-ligand))
(get-ebot (get-element-some obj)))
(define-method (get-elef (obj element-ligand))
(get-elef (get-element-some obj)))
(define-method (get-erig (obj element-ligand))
(get-erig (get-element-some obj)))
(define-method (get-element-name (obj element-ligand))
(get-element-name (get-element-some obj)))
(define-method (get-number-of-dots (obj element-ligand))
(get-number-of-dots (get-element-some obj)))
(define (make-element-ligand element-name number-of-dots nbonds)
(make element-ligand 'element-some (make-element-some element-name number-of-dots) 'nbonds nbonds))
(define (unwrap x) (x (lambda (some) some) (lambda () '())))
(define-syntax element ; three functions with the syntax of one!
(syntax-rules ()
((_)
(lambda (some none) (none)))
((_ element-name number-of-dots)
(lambda (some none)
(some (make-element-some element-name number-of-dots))))
((_ element-name number-of-dots nbonds)
(lambda (some none)
(some (make-element-ligand element-name number-of-dots nbonds))))))
;; Now as for defining the recursive "4 pronged" lewis structure
(define-class lewis-base ()
((element-some reader: get-element-some) ;; the center, which should be an instance of element-some
(element-top reader: get-element-top)
(element-bot reader: get-element-bot)
(element-lef reader: get-element-lef)
(element-rig reader: get-element-rig)))
(define-class element-with-distance ()
((element-ligand reader: get-element-ligand)
(x reader: get-x)
(y reader: get-y)))
(define-method (get-etop (obj element-with-distance))
(get-etop (get-element-ligand obj)))
(define-method (get-ebot (obj element-with-distance))
(get-ebot (get-element-ligand obj)))
(define-method (get-elef (obj element-with-distance))
(get-elef (get-element-ligand obj)))
(define-method (get-erig (obj element-with-distance))
(get-erig (get-element-ligand obj)))
(define-method (get-element-name (obj element-with-distance))
(get-element-name (get-element-ligand obj)))
(define-method (get-number-of-dots (obj element-with-distance))
(get-number-of-dots (get-element-ligand obj)))
(define-method (get-nbonds (obj element-with-distance))
(get-nbonds (get-element-ligand obj)))
(define (element-ligand->element-with-distance element-ligand x y)
(make element-with-distance 'element-ligand element-ligand 'x x 'y y))
(define-class element-with-distance-enumerated ()
((element-with-distance reader: get-element-with-distance)
(etop-enumerated reader: get-etop-enumerated)
(ebot-enumerated reader: get-ebot-enumerated)
(elef-enumerated reader: get-elef-enumerated)
(erig-enumerated reader: get-erig-enumerated)))
(define-method (get-element-ligand (obj element-with-distance-enumerated))
(get-element-ligand (get-element-with-distance obj)))
(define-method (get-etop (obj element-with-distance-enumerated))
(get-etop (get-element-with-distance obj)))
(define-method (get-ebot (obj element-with-distance-enumerated))
(get-ebot (get-element-with-distance obj)))
(define-method (get-elef (obj element-with-distance-enumerated))
(get-elef (get-element-with-distance obj)))
(define-method (get-erig (obj element-with-distance-enumerated))
(get-erig (get-element-with-distance obj)))
(define-method (get-element-name (obj element-with-distance-enumerated))
(get-element-name (get-element-with-distance obj)))
(define-method (get-number-of-dots (obj element-with-distance-enumerated))
(get-number-of-dots (get-element-ligand obj)))
(define-method (get-x (obj element-with-distance-enumerated))
(get-x (get-element-with-distance obj)))
(define-method (get-y (obj element-with-distance-enumerated))
(get-y (get-element-with-distance obj)))
(define-method (get-nbonds (obj element-with-distance-enumerated))
(get-nbonds (get-element-with-distance obj)))
(define (make-element-with-distance-enumerated element-with-distance etop-enumerated ebot-enumerated elef-enumerated erig-enumerated)
(make element-with-distance-enumerated 'element-with-distance element-with-distance
'etop-enumerated etop-enumerated 'ebot-enumerated ebot-enumerated
'elef-enumerated elef-enumerated 'erig-enumerated erig-enumerated))
(define (delpair-based-on-pair pair-bool pair-two)
(let ((tag (gensym)))
(filter (lambda (x) (not (equal? x tag)))
(map (lambda (bool x) (if bool x tag))
pair-bool pair-two))))
(define (enumerate-electrons offset)
(map (lambda (a) (list (+ (car a) offset) (+ (cadr a) offset)))
(map (lambda (a) (list a (+ 4 a)))
(let for ((i 4) (acc '()))
(if (= 0 i)
acc
(for (- i 1) (cons i acc)))))))
(define (caddddr p)
(car (cdr (cdddr p))))
(define (make-lewis-base cen top bot lef rig)
(make lewis-base 'element-some cen 'element-top top 'element-bot bot 'element-lef lef 'element-rig rig))
(define (lewis-base-ligands->lewis-base-ligands-with-distance lewis-base)
(let ((cen (get-element-some lewis-base))
(top (get-element-top lewis-base))
(bot (get-element-bot lewis-base))
(lef (get-element-lef lewis-base))
(rig (get-element-rig lewis-base)))
(let ((top-decorated (top (lambda (element-ligand)
(lambda (some none) (some (element-ligand->element-with-distance
element-ligand 0 125))))
(lambda () (lambda (some none) (none)))))
(bot-decorated (bot (lambda (element-ligand)
(lambda (some none) (some (element-ligand->element-with-distance
element-ligand 0 -125))))
(lambda () (lambda (some none) (none)))))
(lef-decorated (lef (lambda (element-ligand) (lambda (some none) (some
(element-ligand->element-with-distance
element-ligand -125 0))))
(lambda () (lambda (some none) (none)))))
(rig-decorated (rig (lambda (element-ligand) (lambda (some none)
(some (element-ligand->element-with-distance
element-ligand 125 0))))
(lambda () (lambda (some none) (none))))))
(make-lewis-base cen top-decorated bot-decorated lef-decorated rig-decorated))))
(define (element-with-distance->element-with-distance-enumerated element-with-distance lst)
(element-with-distance
(lambda (element-with-distance)
(lambda (some none)
(let ((t (delpair-based-on-pair (get-etop element-with-distance) (car lst)))
(r (delpair-based-on-pair (get-erig element-with-distance) (cadr lst)))
(b (delpair-based-on-pair (get-ebot element-with-distance) (caddr lst)))
(l (delpair-based-on-pair (get-elef element-with-distance) (cadddr lst))))
(some (make-element-with-distance-enumerated element-with-distance t b l r)))))
(lambda () (lambda (some none) (none)))))
(define-class element-some-enumerated ()
((element-some reader: get-element-some)
(etop-enumerated reader: get-etop-enumerated)
(ebot-enumerated reader: get-ebot-enumerated)
(elef-enumerated reader: get-elef-enumerated)
(erig-enumerated reader: get-erig-enumerated)))
(define-method (get-element-name (obj element-some-enumerated))
(get-element-name (get-element-some obj)))
(define-method (get-number-of-dots (obj element-some-enumerated))
(get-number-of-dots (get-element-some obj)))
(define-method (get-etop (obj element-some-enumerated))
(get-etop (get-element-some obj)))
(define-method (get-ebot (obj element-some-enumerated))
(get-ebot (get-element-some obj)))
(define-method (get-elef (obj element-some-enumerated))
(get-elef (get-element-some obj)))
(define-method (get-erig (obj element-some-enumerated))
(get-erig (get-element-some obj)))
(define (make-element-some-enumerated element-some etop-enumerated
ebot-enumerated elef-enumerated erig-enumerated)
(make element-some-enumerated 'element-some element-some
'etop-enumerated etop-enumerated 'ebot-enumerated ebot-enumerated
'elef-enumerated elef-enumerated 'erig-enumerated erig-enumerated))
(define (element-some->element-some-enumerated element-some lst)
(element-some
(lambda (element-some-some)
(lambda (some none)
(let ((t (delpair-based-on-pair (get-etop element-some-some) (car lst)))
(r (delpair-based-on-pair (get-erig element-some-some) (cadr lst)))
(b (delpair-based-on-pair (get-ebot element-some-some) (caddr lst)))
(l (delpair-based-on-pair (get-elef element-some-some) (cadddr lst))))
(some (make-element-some-enumerated element-some-some t b l r)))))
(lambda () (lambda (some none) (none)))))
(define (lewis-base-ligands-with-distance->lewis-base-ligands-enumerated lewis-base)
(let ((cen (get-element-some lewis-base))
(top (get-element-top lewis-base))
(bot (get-element-bot lewis-base))
(lef (get-element-lef lewis-base))
(rig (get-element-rig lewis-base)))
(let* ((cen-enumerated (enumerate-electrons 0))
(cen-offset (+ 1 (get-number-of-dots (unwrap cen))))
(top-enumerated (enumerate-electrons cen-offset))
(top-offset (top (lambda (some) (+ 1 (get-number-of-dots some) cen-offset)) (lambda () cen-offset)))
(rig-enumerated (enumerate-electrons top-offset))
(rig-offset (rig (lambda (some) (+ 1 (get-number-of-dots some) top-offset)) (lambda () top-offset)))
(bot-enumerated (enumerate-electrons rig-offset))
(bot-offset (bot (lambda (some) (+ 1 (get-number-of-dots some) rig-offset)) (lambda () rig-offset)))
(lef-enumerated (enumerate-electrons bot-offset))
(cen-decorated (element-some->element-some-enumerated cen cen-enumerated))
(top-decorated (element-with-distance->element-with-distance-enumerated top top-enumerated))
(rig-decorated (element-with-distance->element-with-distance-enumerated rig rig-enumerated))
(bot-decorated (element-with-distance->element-with-distance-enumerated bot bot-enumerated))
(lef-decorated (element-with-distance->element-with-distance-enumerated lef lef-enumerated)))
(make-lewis-base cen-decorated top-decorated bot-decorated lef-decorated rig-decorated))))
;; Mock object
(define mock (lewis-base-ligands-with-distance->lewis-base-ligands-enumerated
(lewis-base-ligands->lewis-base-ligands-with-distance
(make lewis-base 'element-some (element "C" 4) 'element-top (element) 'element-bot (element) 'element-rig (element "O" 6 2) 'element-lef (element "O" 6 2)))))
(define (gen-layout-string lewis-base)
(let ((cen (get-element-some lewis-base))
(top (get-element-top lewis-base))
(bot (get-element-bot lewis-base))
(lef (get-element-lef lewis-base))
(rig (get-element-rig lewis-base)))
(string-append
(cen (lambda (some) (string-append (get-element-name some) "\n"
(number->string (get-number-of-dots some)) "\n0\n0\n"))
(lambda () ""))
(top (lambda (some) (string-append (get-element-name some) "\n"
(number->string (get-number-of-dots some)) "\n"
(number->string (get-x some)) "\n"
(number->string (get-y some)) "\n"))
(lambda () ""))
(rig (lambda (some) (string-append (get-element-name some) "\n"
(number->string (get-number-of-dots some)) "\n"
(number->string (get-x some)) "\n"
(number->string (get-y some)) "\n"))
(lambda () ""))
(bot (lambda (some) (string-append (get-element-name some) "\n"
(number->string (get-number-of-dots some)) "\n"
(number->string (get-x some)) "\n"
(number->string (get-y some)) "\n"))
(lambda () ""))
(lef (lambda (some) (string-append (get-element-name some) "\n"
(number->string (get-number-of-dots some)) "\n"
(number->string (get-x some)) "\n"
(number->string (get-y some)) "\n"))
(lambda () "")))))
(define (getall-electron-numbers-element-some element-some-enumerated)
(element-some-enumerated (lambda (some)
(let ((top (get-etop-enumerated some))
(rig (get-erig-enumerated some))
(bot (get-ebot-enumerated some))
(lef (get-elef-enumerated some)))
(flatten (list top rig bot lef))))
(lambda () (list))))
(define (each-sender-to-receiver senders-lst receivers-lst)
(let e-s-t-r ((s-list senders-lst) (r-list receivers-lst) (acc '()))
(if (null? s-list)
(flatten acc)
(let* ((fst-s-list (car s-list))
(s-to-r (flatten (map (lambda (a) (list fst-s-list a)) r-list))))
(e-s-t-r (cdr s-list) r-list (cons s-to-r acc))))))
(define cen-dir 0)
(define top-dir 1)
(define rig-dir 2)
(define bot-dir 3)
(define lef-dir 4)
(define (unwrap-enumerated-electrons element dir)
(cond
((= dir top-dir)
(element (lambda (some) (get-etop-enumerated some)) (lambda () #f)))
((= dir rig-dir)
(element (lambda (some) (get-erig-enumerated some)) (lambda () #f)))
((= dir bot-dir)
(element (lambda (some) (get-ebot-enumerated some)) (lambda () #f)))
((= dir lef-dir)
(element (lambda (some) (get-elef-enumerated some)) (lambda () #f)))))
(define (permutgen-first-level lewis-base)
(let ((cen (get-element-some lewis-base))
(top (get-element-top lewis-base))
(bot (get-element-bot lewis-base))
(lef (get-element-lef lewis-base))
(rig (get-element-rig lewis-base)))
(let ((top-nbonds (top (lambda (some) (get-nbonds some)) (lambda () #f)))
(bot-nbonds (bot (lambda (some) (get-nbonds some)) (lambda () #f)))
(lef-nbonds (lef (lambda (some) (get-nbonds some)) (lambda () #f)))
(rig-nbonds (rig (lambda (some) (get-nbonds some)) (lambda () #f))))
(let ((top-senders (if top-nbonds (getall-electron-numbers-element-some top) #f))
(bot-senders (if bot-nbonds (getall-electron-numbers-element-some bot) #f))
(lef-senders (if lef-nbonds (getall-electron-numbers-element-some lef) #f))
(rig-senders (if rig-nbonds (getall-electron-numbers-element-some rig) #f))
(cen-revievers (getall-electron-numbers-element-some cen)))
(let ((cen-top-enumerated (unwrap-enumerated-electrons cen top-dir))
(cen-bot-enumerated (unwrap-enumerated-electrons cen bot-dir))
(cen-lef-enumerated (unwrap-enumerated-electrons cen lef-dir))
(cen-rig-enumerated (unwrap-enumerated-electrons cen rig-dir)))
(flatten (list (if (and top-senders cen-top-enumerated)
(each-sender-to-receiver top-senders cen-top-enumerated) '())
(if (and bot-senders cen-bot-enumerated)
(each-sender-to-receiver bot-senders cen-bot-enumerated) '())
(if (and lef-senders cen-lef-enumerated)
(each-sender-to-receiver lef-senders cen-lef-enumerated) '())
(if (and rig-senders cen-rig-enumerated)
(each-sender-to-receiver rig-senders cen-rig-enumerated) '()))))))))
(define (gen-verts lewis-base)
(let ((cen (get-element-some lewis-base))
(top (get-element-top lewis-base))
(bot (get-element-bot lewis-base)))
(let ((cen-top-enumerated (unwrap-enumerated-electrons cen top-dir))
(cen-bot-enumerated (unwrap-enumerated-electrons cen bot-dir))
(top-bot-enumerated (unwrap-enumerated-electrons top bot-dir))
(bot-top-enumerated (unwrap-enumerated-electrons bot top-dir)))
(flatten (list (if (and cen-top-enumerated top-bot-enumerated)
(list (each-sender-to-receiver cen-top-enumerated top-bot-enumerated)
(each-sender-to-receiver top-bot-enumerated cen-top-enumerated))
'())
(if (and cen-bot-enumerated bot-top-enumerated)
(list (each-sender-to-receiver cen-top-enumerated bot-top-enumerated)
(each-sender-to-receiver bot-top-enumerated cen-top-enumerated))
'()))))))
(define (nlist->ret-sep-list lst)
(if (null? lst)
""
(foldr string-append "" (map (lambda (n) (string-append (number->string n) "\n")) lst))))
;; (make lewis-base 'element-some (element "C" 4) 'element-top (element) 'element-bot (element) 'element-rig (element "O" 6 2) 'element-lef (element "O" 6 2)))))
(define (make-level lewis-base)
(string-append "#This level's element initlist begins\n"
(gen-layout-string lewis-base)
"~~~\n"
"#This level's permutations of electron combinations begins\n"
(nlist->ret-sep-list (permutgen-first-level lewis-base))
"\n"
"~~~\n"
"#This level's list of vertical bonds begins\n"
(nlist->ret-sep-list (gen-verts mock))
"~~~\n"))
(define (get-level-file file)
(call-with-input-file file (lambda (in) (read-lines in))))
(define-syntax whenf
(syntax-rules ()
((_ pred condition)
(if pred condition #f))))
(define (parse-line-of-input-file line)
(whenf (>= (string-length line) 7)
(whenf (string= (substring line 0 7) "element")
(let ((split (irregex-split " " line)))
(cond ((= 4 (length split))
(element (cadr split) (string->number (caddr split))
(string->number (cadddr split))))
((= 3 (length split))
(element (cadr split) (string->number (caddr split))))
((= 1 (length split))
(element)))))))
#;(define (make-lewis-base cen top bot lef rig)
(make lewis-base 'element-some cen 'element-top top 'element-bot bot 'element-lef lef 'element-rig rig))
(define make-lewis-base-curried
(lambda (cen) (lambda (top) (lambda (bot) (lambda (lef) (lambda (rig)
(make-lewis-base cen top bot lef rig)))))))
(define (funcallif proc . arg)
(if (car arg)
(apply proc arg)
proc))
(define (lines->lewis-base-list lines)
(let r-t-l ((lns lines) (proc make-lewis-base-curried) (acc '()))
;; the code for getting a lewis-base from 5 lines of the level file
(if (procedure? proc)
(r-t-l (cdr lns) (let ((parsed (parse-line-of-input-file (car lns))))
(if parsed
(proc parsed)
proc)) acc)
(if (null? lns)
(reverse (cons proc acc))
(r-t-l lns make-lewis-base-curried (cons proc acc))))))
#;(define mock (lewis-base-ligands-with-distance->lewis-base-ligands-enumerated
(lewis-base-ligands->lewis-base-ligands-with-distance
(make lewis-base 'element-some (element "C" 4) 'element-top (element) 'element-bot (element) 'element-rig (element "O" 6 2) 'element-lef (element "O" 6 2)))))
(define (lewis-base->level lewis-base)
(make-level
(lewis-base-ligands-with-distance->lewis-base-ligands-enumerated
(lewis-base-ligands->lewis-base-ligands-with-distance
lewis-base))))
(define (lewis-base-list->levels lst)
(foldr string-append "" (map lewis-base->level lst)))
(unless (irregex-search "csi" (car (argv)))
(define infile (parley "Input file name?"))
(define outfile (parley "Output file name?"))
(define level (lewis-base-list->levels (lines->lewis-base-list (get-level-file infile))))
(with-output-to-file outfile (lambda () (display level))))