working on it ...

Filters

snippets
588
followers
4
Published by snip2code

Scheme

This channel collects useful snippets for Scheme language
Sort by

Found 588 snippets

    public by snip2code modified Aug 13, 2017  117  0  3  1

    First Snippet: How to play with Snip2Code

    This is the first example of a snippet: - the title represents in few words which is the exact issue the snippet resolves; it can be something like the name of a method; - the description (this field) is an optional field where you can add interesting information regarding the snippet; something like the comment on the head of a method; - the c
    /* place here the actual content of your snippet. 
       It should be code or pseudo-code. 
       The less dependencies from external stuff, the better! */

    public by cuhardware modified Jan 6, 2016  1789  0  5  0

    Loop 4 times with condition

    try=0
    while [ $try -lt 4 ]; do
    	try=$((try+1))
    done

    external by Fabian Parzefall modified Monday at 10:14:00 PM  5  0  1  0

    Mergesort implemented in Scheme

    Mergesort implemented in Scheme: mergesort.scm
    (define (mergesort L)
      ; Merges to list by prepending always the lowest element of both lists (which are already sorted)
      ; to the result (which is a recursive call on the list without the prepended element).
      (define (merge-lists first second)
        (cond ((and (null? first) (null? second)) '())
              ((null? first) (cons (car second) (merge-lists first (cdr second))))
              ((null? second) (cons (car first) (merge-lists (cdr first) second)))
              ((< (car first) (car second)) (cons (car first) (merge-lists (cdr first) second)))
              (else (cons (car second) (merge-lists first (cdr second))))))
    
      ; Merge all pairs of lists next to each other.
      (define (merge-step in out)
        (if (null? in)
            out
            (if (null? (cdr in))
                (cons (car in) out)
                (merge-step (cddr in) (cons (merge-lists (car in) (cadr in)) out)))))
    
      ; Perform the merge-step until only the sorted list is left.
      (define (merge list)
        (if (null? (cdr list))
            (car list)
            (merge (merge-step list '()))))
    
      (if (null? (cdr L))
          L
          ; Start by splitting the list up in lists consisting of one element each.
          (merge (map list L)))
      )
    
    (display (mergesort '(1 17 8 9 3 4))) (newline)
    (display (mergesort '(8))) (newline)
    (display (mergesort '(1 8 10 8 100 8 8 8 9))) (newline)
    
    
    

    external by Vee Satayamas modified Nov 13, 2017  4  0  1  0

    A small guile/scheme script for reading translation memery in TMX format

    A small guile/scheme script for reading translation memery in TMX format: tmx-read.scm
    ;; -*- geiser-scheme-implementation: guile -*
    ;;
    ;; Reading TMX (translation memory)
    ;;
    ;; Copyright (c) 2017 Vee Satayamas.
    ;; All rights reserved.
    ;;
    ;; Redistribution and use in source and binary forms, with or without
    ;; modification, are permitted provided that the following conditions
    ;; are met:
    ;; 1. Redistributions of source code must retain the above copyright
    ;;    notice, this list of conditions and the following disclaimer.
    ;; 2. Redistributions in binary form must reproduce the above copyright
    ;;    notice, this list of conditions and the following disclaimer in the
    ;;    documentation and/or other materials provided with the distribution.
    ;;
    ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
    ;; ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
    ;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
    ;; PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE FOUNDATION OR CONTRIBUTORS
    ;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
    ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
    ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
    ;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
    ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
    ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
    ;; POSSIBILITY OF SUCH DAMAGE.
    
    
    (use-modules (srfi srfi-26))
    (use-modules (sxml simple))
    (use-modules (ice-9 pretty-print))
    
    (define (read-xml file-path)
      (call-with-input-file file-path
        (lambda (port)
          (xml->sxml port))))
    
    (define (select-children-by-tag node tag)
      (let* ((children (cddr node))
             (non-text-children (filter list? children))
             (eq-tag? (lambda (node)
                        (eq? tag (car node)))))
        (filter eq-tag? non-text-children)))
    
    (define (tuv->text tuv)
      (let* ((segments (select-children-by-tag tuv 'seg))
             (texts (map (cut cadr <>) segments)))
        (car texts)))
    
    (define (tmx->textpairs tmx)
      (let* ((body (car (select-children-by-tag tmx 'body)))
             (tu-nodes (select-children-by-tag body 'tu))
             (tuv-pairs (map (cut select-children-by-tag <> 'tuv)
                             tu-nodes)))
        (map (cut map tuv->text <>) tuv-pairs)))
    
    (define (read-tmx file-path)
      (let* ((xml (read-xml file-path))
             (tmx (caddr xml)))
        (tmx->textpairs tmx)))
    
    ; (display (vector-ref (list->vector (read-tmx "th.mozillaorg.tmx")) 18))
    
    
    

    external by rsp modified Nov 6, 2017  4  0  1  0

    Language Wars - Church numerals - Scheme

    Language Wars - Church numerals - Scheme: languagewars-churchnumerals-scheme.scm
    (define suc (lambda (a) (lambda (b) (lambda (c) (b ((a b) c))))))
    (define add (lambda (a) (lambda (b) (lambda (c) (lambda (d) ((a c) ((b c) d)))))))
    (define mul (lambda (a) (lambda (b) (lambda (c) (a (b c))))))
    (define exp (lambda (a) (lambda (b) (b a))))
    (define pre (lambda (a) (lambda (b) (lambda (c)
      (((a (lambda (d) (lambda (e) (e (d b))))) (lambda (f) c)) (lambda (g) g))))))
    (define sub (lambda (a) (lambda (b) ((b pre) a))))
    (define ntc (lambda (n) (if (> n 0)
      (lambda (a) (lambda (b) (a (((ntc (- n 1)) a) b))))
      (lambda (a) (lambda (b) b)))))
    (define ctn (lambda (a) ((a (lambda (x) (+ x 1))) 0)))
    
    

    external by Jacek Zlydach modified Nov 4, 2017  4  0  1  0

    GuixSD with custom kernel

    GuixSD with custom kernel: config.scm
    (define-module (my packages)
      #:use-module ((guix licenses) #:prefix license:)
      #:use-module (gnu packages linux)
      #:use-module (guix build-system trivial)
      #:use-module (gnu)
      #:use-module (guix download)
      #:use-module (guix git-download)
      #:use-module (guix packages))
    
    (define (linux-nonfree-urls version)
      "Return a list of URLs for Linux-Nonfree VERSION."
      (list (string-append
             "https://www.kernel.org/pub/linux/kernel/v4.x/"
             "linux-" version ".tar.xz")))
    
    ;; Remove this and native-inputs below to use the default config from Guix.
    ;; Make sure the kernel minor version matches, though.
    (define kernel-config
      (string-append (dirname (current-filename)) "/kernel.config"))
    
    (define-public linux-nonfree
      (package
        (inherit linux-libre)
        (name "linux-nonfree")
        (version "4.13.11")
        (source (origin
                  (method url-fetch)
                  (uri (linux-nonfree-urls version))
                  (sha256
                   (base32
                    "1vzl2i72c8iidhdc8a490npsbk7q7iphjqil4i9609disqw75gx4"))))
        (native-inputs
         `(("kconfig" ,kernel-config)
           ,@(alist-delete "kconfig"
                           (package-native-inputs linux-libre))))
        (synopsis "Mainline Linux kernel, nonfree binary blobs included")
        (description "Linux is a kernel.")
        (license license:gpl2)              ;XXX with proprietary firmware
        (home-page "https://kernel.org")))
    
    (define (linux-firmware-version) "9d40a17beaf271e6ad47a5e714a296100eef4692")
    (define (linux-firmware-source version)
      (origin
        (method git-fetch)
        (uri (git-reference
              (url (string-append "https://git.kernel.org/pub/scm/linux/kernel"
                                  "/git/firmware/linux-firmware.git"))
              (commit version)))
        (file-name (string-append "linux-firmware-" version "-checkout"))
        (sha256
         (base32
          "099kll2n1zvps5qawnbm6c75khgn81j8ns0widiw0lnwm8s9q6ch"))))
    
    (define-public iwlwifi-firmware-nonfree
      (package
        (name "iwlwifi-firmware-nonfree")
        (version (linux-firmware-version))
        (source (linux-firmware-source version))
        (build-system trivial-build-system)
        (arguments
         `(#:modules ((guix build utils))
           #:builder (begin
                       (use-modules (guix build utils))
                       (let ((source (assoc-ref %build-inputs "source"))
                             (fw-dir (string-append %output "/lib/firmware/")))
                         (mkdir-p fw-dir)
                         (for-each (lambda (file)
                                     (copy-file file
                                                (string-append fw-dir (basename file))))
                                   (find-files source
                                               "iwlwifi-.*\\.ucode$|LICENSE\\.iwlwifi_firmware$"))
                         #t))))
        (home-page "https://wireless.wiki.kernel.org/en/users/drivers/iwlwifi")
        (synopsis "Non-free firmware for Intel wifi chips")
        (description "Non-free iwlwifi firmware")
        (license (license:non-copyleft
                  "https://git.kernel.org/cgit/linux/kernel/git/firmware/linux-firmware.git/tree/LICENCE.iwlwifi_firmware?id=HEAD"))))
    
    
    
    (define %sysctl-activation-service
      (simple-service 'sysctl activation-service-type
    		  #~(let ((sysctl
    			   (lambda (str)
    			     (zero? (apply system*
    					   #$(file-append procps
    							  "/sbin/sysctl")
    					   "-w" (string-tokenize str))))))
    		      (and
    		       ;; Enable IPv6 privacy extensions.
    		       (sysctl "net.ipv6.conf.eth0.use_tempaddr=2")
    		       ;; Enable SYN cookie protection.
    		       (sysctl "net.ipv4.tcp_syncookies=1")
    		       ;; Log Martian packets.
    		       (sysctl "net.ipv4.conf.default.log_martians=1")))))
    
    (define %powertop-service
      (simple-service 'powertop activation-service-type
    		  #~(zero? (system* #$(file-append powertop "/sbin/powertop")
    				    "--auto-tune"))))
    
    
    
    (use-modules (gnu)
                 (guix store)               ;for %default-substitute-urls
                 (gnu system nss)
                 (my packages)
                 (srfi srfi-1))
    (use-service-modules admin base dbus desktop mcron networking ssh xorg sddm)
    (use-package-modules admin bootloaders certs disk fonts file emacs
                         libusb linux version-control
                         ssh tls tmux wm xdisorg xorg)
    
    (operating-system
      (host-name "kirby")
      (timezone "Europe/Oslo")
      (kernel linux-nonfree)
      (kernel-arguments '("modprobe.blacklist=pcspkr,snd_pcsp"))
      ;; (locale "en_GB.utf8")
      ;; (locale-libcs (list glibc-2.24 (canonical-package glibc)))
      (firmware (append (list
                         iwlwifi-firmware-nonfree)
                        %base-firmware))
    
      (mapped-devices (list (mapped-device
                             (source "/dev/sda4")
                             (type luks-device-mapping)
                             (target "guixhome"))))
    
      (bootloader (bootloader-configuration
                   (bootloader grub-efi-bootloader)
                   (target "/boot/efi")))
    
      (file-systems (cons* (file-system
                             (device "guixroot")
                             (title 'label)
                             (mount-point "/")
                             (needed-for-boot? #t)
                             (type "ext4"))
                           (file-system
                             (device "/dev/mapper/guixhome")
                             (mount-point "/home")
                             (type "ext4"))
                           (file-system
                             (device "/dev/sda2")
                             (mount-point "/boot")
                             (type "vfat"))
                           %base-file-systems))
    
      (groups (cons (user-group
                     (name "marius"))
                    %base-groups))
      (users (cons (user-account
                    (name "marius")
                    (comment "Meh")
                    (group "marius")
                    (supplementary-groups '("wheel" "netdev" "audio" "video" "kvm" "disk"))
                    (home-directory "/home/marius"))
                   %base-user-accounts))
    
      (packages (cons*
                 dosfstools
                 nss-certs
                 htop
                 wpa-supplicant
                 acpid
                 i3-wm
                 i3status
                 xscreensaver
                 %base-packages))
      (services (cons*
                 (sddm-service)
                 (screen-locker-service xscreensaver)
                 (service wpa-supplicant-service-type)
                 (service network-manager-service-type)
                 (upower-service)
                 (colord-service)
                 ;;(geoclue-service)
                 (polkit-service)
                 (elogind-service)
                 (dbus-service)
                 (service rottlog-service-type (rottlog-configuration))
                 (service mcron-service-type)
    	     %sysctl-activation-service
    	     %powertop-service
    
                 ;; Add udev rules for MTP devices so that non-root users can access
                 ;; them.
                 (simple-service 'mtp udev-service-type (list libmtp))
    
                 ;; Store the current configuration with the generation.
                 (simple-service 'store-my-config
                                 etc-service-type
                                 `(("current-config.scm"
                                    ,(local-file (assoc-ref
                                                  (current-source-location)
                                                  'filename)))))
                 (ntp-service #:servers '("nissen.uio.no"
                                          "2.no.pool.ntp.org"
                                          "1.no.pool.ntp.org"
                                          "0.sv.pool.ntp.org"))
                 (modify-services %base-services
                   (guix-service-type
                    config =>
                    (guix-configuration
                     (inherit config)
                     (substitute-urls
                      (cons* "http://192.168.2.11:8181"
                             "http://192.168.2.5:3000"
                             "http://137.205.52.16"
                             %default-substitute-urls))))))))
    
    

    external by Maurits Lamers modified Nov 4, 2017  5  0  1  0

    Problem with case

    Problem with case: test.scm
    (case "|." ;(assoc-ref evt 'whichBar)
      ( ("|") (assoc-ref brailleMusicSymbols 'normal-bar-line))
      ( ("|.") (assoc-ref brailleMusicSymbols 'double-bar-end))
      ( ("||") (assoc-ref brailleMusicSymbols 'double-bar))
      ( ("!") (assoc-ref brailleMusicSymbols 'dotted-bar-line))
      )
    
    
    

    external by lazywithclass modified Oct 27, 2017  6  0  1  0

    Exercises after The Little Schemer chapter 2 (2)

    Exercises after The Little Schemer chapter 2 (2): exercises.scm
    ;; in the previous solution we implemented 2nd and last
    ;; but we did not define proper return values for the edge cases,
    ;; this time we will
    
    ;; your task will be to provide those values, as you can imagine
    ;; (sum 4 'gatto) does not have an answer
    ;; make it so that expressions will return true
    
    ;; a suggestion would be to paste the definitions of 2nd and last
    ;; above the exercises and fix the errors you get, by returning proper values
    
    ;; this is the implementation of the sum function used below
    (define sum
      (lambda (n m)
          (+ n m)))
    
    (eq? 6 (sum (second '(2 4)) (last '(2)))) ;; this one already returns true
    
    (eq? 2 (sum (second '(1 2 3)) (last '())))
    
    (eq? (second '()) (last '()))
    
    ;; your second and last exercise is to implement the nth function
    ;; which given a list and a number returns the item in the list at that position
    ;; for example
    (nth '(1 2 3) 0) ;; 1
    (nth '(1 2 3) 1) ;; 2
    ;; assume that you will be given a lat, provide meaningful return values for edge cases
    
    

    external by plodsoft modified Oct 25, 2017  4  0  1  0

    A simple implementation of the hygienic macro expander described in Macros-That-Work

    A simple implementation of the hygienic macro expander described in Macros-That-Work: macros_that_work.scm
    ;;; A simple macro expander implementation based on Macros That Work.
    ;;; Macros That Work, William Clinger, Jonathan Rees.
    
    ;;; Usage:
    ;;; (macroexpand s-exp) yields a fully expanded form
    ;;;
    ;;; Supported special forms:
    ;;; if
    ;;; set!
    ;;; begin
    ;;; quote
    ;;; lambda
    ;;; 
    
    ;;;;;;;;;       environment
    ;; identifier -> identifier or local macro procedure
    
    (define (extend-env* vars dens env)
      (append (map cons vars dens) env))
      
    (define (extend-env var den env)
      (cons (cons var den) env))
      
    (define (apply-env env name)
      (cond
        [(assq name env) => cdr]
        [else name]))
        
    (define macro? procedure?)
    
    ;;;;;;;;;;  marking (renaming)
        
    (define new-mark #f)
    
    (define (init-mark!)
      (set! new-mark
        (let ([i 0])
          (lambda ()
            (set! i (+ i 1))
            i))))
    
    (define (mark-identifier name mark)
      (string->symbol
       (string-append
        (symbol->string name)
        "."
        (number->string mark))))
        
    (define (unmark e env)
      (cond
        [(symbol? e)
         (if (marked-identifier? e)
             (apply-env env e)
             e)]
        [(pair? e)   (cons (unmark (car e) env)
                           (unmark (cdr e) env))]
        [else e]))
    
    (define (marked-identifier? name)
      (let ([dot (memq
                  #\.
                  (string->list
                   (symbol->string name)))])
        (and dot
             (string->number
              (list->string (cdr dot))))))
    
    ;;;;;;;;;  helper functions
            
    ;; works for both lists and dotted lists
    (define (map1* f ls)
      (cond
        [(null? ls) '()]
        [(pair? ls) (cons (f (car ls))
                          (map1* f (cdr ls)))]
        [else       (f ls)]))
    
    ;; convert (dotted) list to list
    (define (dotted->list ls)
      (cond
        [(null? ls) '()]
        [(pair? ls) (cons (car ls)
                          (dotted->list (cdr ls)))]
        [else       (cons ls '())]))
    
    ;;;;;;;;;; macro expander
    
    (define (macroexpand e)
      (init-mark!)
      (expand-help e '()))
    
    (define (expand-help e env)
      (cond
        [(symbol? e)
         (let ([den (apply-env env e)])
           (if (macro? den)
               (error 'macroexpand "Invalid syntax" e)
               den))]
        [(pair? e)
         (let ([den (apply-env env (car e))])
           (case den
             [(if)
              `(if ,(expand-help (cadr e) env)
                   ,(expand-help (caddr e) env)
                   ,(expand-help (cadddr e) env))]
             [(set!)
              `(set! ,(expand-help (cadr e) env)
                 ,(expand-help (caddr e) env))]
             [(quote)
              `(quote ,(unmark (cadr e) env))]
             [(begin)
              `(begin . ,(map (lambda (e)
                                (expand-help e env))
                              env))]
             [(lambda)
              (let* ([mark     (new-mark)]
                     [new-vars (map1* (lambda (name)
                                         
                                        (mark-identifier
                                         ;; a lambda may be introduced by a macro,
                                         ;; of which the formal arguments are marked.
                                         ;; We need to unmark them first.
                                         (unmark name env)
                                          mark))
                                      (cadr e))]
                     [env      (extend-env* (dotted->list (cadr e))
                                            (dotted->list new-vars)
                                            env)])
                `(lambda ,new-vars
                   . ,(map (lambda (e)
                             (expand-help e env))
                           (cddr e))))]
             [(syntax-rules)
              (make-macro-transformer (cadr e) (cddr e) env)]
             [(let-syntax)
              (let ([env (extend-env*
                          (map car (cadr e))
                          (map (lambda (p)
                                 (expand-help (cadr p) env))
                               (cadr e))
                          env)])
                `(begin
                   . ,(map (lambda (x)
                             (expand-help x env))
                           (cddr e))))]
             [else
              (if (macro? den)
                  (let-values ([(e env) (den e env)])
                    (expand-help e env))
                  (map1* (lambda (e)
                           (expand-help e env))
                         e))]))]
        [else e]))
    
    ;;;;;;;;;;   macro transformer
    
    (define macro-transformer? procedure?)
    
    (define (make-macro-transformer literals rules def-env)
      (lambda (e use-env)
        (let loop ([rules rules])
          (if (null? rules)
              (error 'macroexpand "Invalid syntax" e)
              (let ([pattern  (caar rules)]
                    [template (cadar rules)])
                (let ([bindings (match e pattern literals use-env def-env)])
                  (if bindings
                      (transcribe template bindings use-env def-env)
                      (loop (cdr rules)))))))))
        
    (define (match e pattern literals use-env def-env)
      (call/cc
       (lambda (fail)
         (let rec ([e (cdr e)] [pattern (cdr pattern)])
           (cond
             [(symbol? pattern)
              (if (memq pattern literals)
                  (if (eq? (apply-env use-env e)
                           (apply-env def-env pattern))
                      '()
                      (fail #f))
                  (list (cons pattern e)))]
             [(pair? pattern)
              (if (pair? e)
                  (append (rec (car e) (car pattern))
                          (rec (cdr e) (cdr pattern)))
                  (fail #f))]
             [else
              (if (eqv? e pattern)
                  '()
                  (fail #f))])))))
    
    (define (transcribe template bindings use-env def-env)
      (letrec ([mark (new-mark)]
               [rec (lambda (template)
                      (cond
                        [(symbol? template)
                         (cond
                          [(assq template bindings) => cdr]
                          [else
                           (let ([new-id (mark-identifier template mark)])
                             (set! use-env
                                (extend-env new-id
                                            (apply-env def-env template)
                                            use-env))
                             new-id)])]
                        [(pair? template)
                         (cons (rec (car template))
                               (rec (cdr template)))]
                        [else template]))])
        (let ([e1 (rec template)])
          (values e1 use-env))))
    
    
    ;;;;;;;;;;;;;;;; test
    
    (define-syntax test
      (syntax-rules ()
        [(_ e res)
         (let ([ret (macroexpand 'e)])
           (if (not (equal? ret 'res))
               (error 'test "test failed" 'e 'res)))]))
               
    (test (lambda (x y)
            (cons y
                  (lambda y
                    (if (> y x)
                        (set! z (+ x y))
                        '(x y z 10)))))
          (lambda (x.1 y.1)
            (cons y.1
                  (lambda y.2
                    (if (> y.2 x.1)
                        (set! z (+ x.1 y.2))
                        '(x y z 10))))))
                        
    (test (let-syntax
            ([foo (syntax-rules ()
                    [(_ (x) y)  (x (y x))])])
            (foo (1) 2))
          (begin
            (1 (2 1))))
                        
    (test (let-syntax
            ([foo (syntax-rules (xx)
                    [(_ xx a)
                     (lambda (t1 t2)
                       t1
                       '(xx (yy a)))]
                    [(_ y a)
                     (a y x)])])
            ((foo xx 123)
             (lambda (xx x)
               (foo xx x))))
          (begin
            ((lambda (t1.2 t2.2)
               t1.2
               '(xx (yy 123)))
             (lambda (xx.3 x.3)
               (x.3 xx.3 x)))))
              
    (test (lambda (x)
            (let-syntax
              ([foo (syntax-rules ()
                      [(_ y) (x y)])])
              ((foo x)
               (lambda (x)
                 (foo x)))))
          (lambda (x.1)
            (begin
              ((x.1 x.1)
               (lambda (x.3)
                 (x.1 x.3))))))
    
    

    external by Akira Takahashi modified Oct 23, 2017  5  0  1  0

    DFAの最小化

    DFAの最小化: mindfa2.scm
    (use srfi-1)
    (use srfi-13)
    
    (define (deldup x)
        (cond ((null? x) ())
              ((member (car x) (cdr x)) (deldup (cdr x)))
              (else (cons (car x) (deldup (cdr x))))))
    
    (define (dpro  x y)
      (if (null? y) () (append  (mkpair x (car y))  (dpro x (cdr y)))))
    
    (define (mkpair x a)
      (if (null? x) '()
          (cons (list (car x) a) (mkpair (cdr x) a))))
    
    
    (define (normq qp)
      (if (string-ci> (atom2str (car qp)) (atom2str (cadr qp)))
          (list (cadr qp)  (car qp))
          qp))
    
    (define (atom2str x)
        (cond ((number? x) (number->string x))
              ((symbol? x) (symbol->string x))
              (else x)))
    
    (define delta1 '(
                      ((a 0) b) ((a 1) e) ((a 2) e)
                      ((b 0) d) ((b 1) c) ((b 2) c)
                      ((c 0) d) ((c 1) b) ((c 2) b)
                      ((d 0) c) ((d 1) g) ((d 2) g)
                      ((e 0) f) ((e 1) b) ((e 2) b)
                      ((f 0) g) ((f 1) e) ((f 2) e)
                      ((g 0) c) ((g 1) d) ((g 2) d)
                      ))
    
    (define M1 `((a b c d e f g) (0 1) ,delta1 a (c d)))
    
    
    (define delta2 '(
                    ((q_0 a) q_3) ((q_0 b) q_1)
                    ((q_1 a) q_1) ((q_1 b) q_2)
                    ((q_2 a) q_4) ((q_2 b) q_1)
                    ((q_3 a) q_0) ((q_3 b) q_1)
                    ((q_4 a) q_2) ((q_4 b) q_1)
                    ))
    
    (define M2 `((q_0 q_1 q_2 q_3 q_4) (a b) ,delta2 q_0 (q_2 q_4)))
    
    #|
    
    \usepackage{ascmac}
    \usepackage{color}
    \usepackage[dvipdfmx]{graphicx}
    \usepackage{tikz}
    \usetikzlibrary{positioning}
    \usetikzlibrary{arrows,automata}
    \usepackage{tikz-qtree}
    \usetikzlibrary{matrix}
    \usepackage{amsmath}
    \usepackage{amssymb}
    \usepackage{colortbl}
    \usepackage{multicol}
    \usepackage{ecltree,epic,eepic}
    \usepackage {bc128}
    \usepackage{jacntmrk}
    \usepackage{array}
    
    \newcolumntype{I}{!{\vrule width 1.2pt}}
    \newcommand{\bhline}[1]{\noalign{\hrule height #1}}
    
    \newenvironment{nquote}[1]{\list{}{\leftmargin=#1}\item[]}{\endlist}
    
    % \renewcommand{\labelenumi}{\roman{enumi}.}
    % \renewcommand{\labelenumi}{\alph{enumi}.}
    
    \newcommand{\maru}[1]{\ooalign{
    \hfil\resizebox{.9\width}{\height}{#1}\hfil
    \crcr
    \raise-.2ex\hbox{\Large$\bigcirc$}}}
    
    |#
    
    
    (define (stset x) ; for print
      (let ((r ""))
        (set! r (string-append (format #f "\\{") r))
        (for-each (lambda (s) (set! r (string-append r (format #f "\\,~A," s)))) x)
        (set! r (string-append (substring r 0 (- (string-length r) 1)) (format #f "\\,\\}")))
        r))
    
    (define (prq q) (format #t "$(~A \\: ~A)$" (car q) (cadr q)))
    (define (pdelta x i y) (format #t "$\\delta(~A,~A) = ~A $ " x i y))
    (define (pbatsu qp) (format #t "$(~A \\: ~A)$ に $ \\times  $をつける\\\\" (car qp) (cadr qp)))
    (define (hr) (format #t "\\vskip 3mm\\hrulefill\n\\vskip 3mm\n"))
    
    (define (ptrfig dfa)
      
      (define (delta  q i dt) ; dt(q,i)
        (let ((d (assoc  (list q i) dt)))
          (if d (cadr d) #f)))
    
      (let* ((*qs* (car dfa)) (*sigma* (cadr dfa)) (*delta* (caddr dfa)) (*ss* (cadddr dfa)) (*fs* (car (cddddr dfa)))
            (l (+ (length *sigma*) 2)))
    
        (format #t "\\begin{minipage}{0.6\\hsize}\n\\begin{itembox}[l]{ ~A }\n" "形式的定義")
        
        (format  #t "$ M = ( ~A , ~A , ~A , ~A , ~A ) $\n" (stset *qs*) (stset *sigma*) "\\delta" (format #f " ~A " *ss*) (stset *fs*))
    
        (format  #t "\n$\n\\begin{matrix}\n")
        (for-each  (lambda (q)
                     (format #t "\\multicolumn{1}{c}{}")
                     (for-each (lambda (i)
                                 (format #t " & \\delta(~A\\,,~A) = ~A  \\: " q i (delta q i *delta*)))
                               *sigma*)
                     (format  #t "\\\\ \n")
                     )
                     *qs*)
        (format #t "\\end{matrix}\n$\n")
        (format #t "\\end{itembox}\n\\end{minipage}\n")
        (format #t "\\begin{minipage}{0.3\\hsize}\n\\begin{itembox}[l]{ ~A }\n" "状態遷移表による定義")
        (format #t "\n$\n\\begin{matrix}\\cline{2-~A}\n" l)
        (format #t "\\multicolumn{1}{c|}{}")
        (format #t "& \\multicolumn{1}{c|}{\\delta}")
        (for-each (lambda (i)
                    (format #t "& \\multicolumn{1}{c|}{~A} " i))
                    *sigma*)
        (format  #t "\\\\ \\cline{2-~A}\n" l)
        (for-each
         (lambda (q)
           (if (eq? q *ss*)
               (format #t "\\multicolumn{1}{c|}{\\to}" )
               (format #t "\\multicolumn{1}{c|}{} "))
           (if (member q *fs*)
               (format #t "& \\multicolumn{1}{c|}{\\maru{$~A$}} " q)
               (format #t "& \\multicolumn{1}{c|}{~A} " q))
           (for-each (lambda (i)
                       (format #t "& \\multicolumn{1}{c|}{~A} " (delta q i *delta*)))
                     *sigma*)
           (format  #t "\\\\ \\cline{2-~A}\n" l))
         *qs*)
        (format #t "\\end{matrix}\n$\n\n")
        (format #t "\\end{itembox}\n\\end{minipage}\n\n")
        (hr)
        ))
    
    
    ;;;;;;
    
    (define (minimize dfa)
        (let ((*qs* (car dfa)) (*sigma* (cadr dfa)) (*delta* (caddr dfa)) (*ss* (cadddr dfa)) (*fs* (car (cddddr dfa)))
              (*r* ()) (*p* ()))
    
          (define (delta  q i) ; i 状態 q で i が入力されたときの状態を返す
            (let ((d (assoc  (list q i) *delta*)))
              (if d (cadr d) #f)))
    
          (define (nextq qp i) (map (lambda (x) (delta x i)) qp))
    
          (define (msg1 qp)
            (let ((a (car qp)) (b (cadr qp)))
              (for-each
               (lambda (x)
                 (let ((c (delta a x)) (d (delta b x)))
                   (pdelta a x c)
                   (display ",")
                   (pdelta b x d)
                   (display "\\,:\\, 推移先")
                   (prq  (list c d))
                   (cond ((equal? (normq qp) (normq (list c d))) (print "は同じ状態対\\\\"))
                         ((eq? c d) (print " は同じ状態\\\\"))
                         ((member (normq (list c d)) *r*) (print " には $ \\times $  がついているので区別可能\\\\"))
                         (else (print " には$ \\times $ がついていない\\\\")))
                   ))
               *sigma*)))
    
          (define (nextqsq qp)  (map (lambda (x) (nextq qp x)) *sigma*))
    
          (define (deltrivpending pds)
            (remove (lambda (x)
                      (let* ((fq (car x)) (tq (cadr x))
                             (a (car tq)) (b (cadr tq)))
                        (or (eq? (car tq) (cadr tq))
                            (equal? fq tq)
                            (equal? fq (list b a)))
                        ))
                    pds))
    
          (define (distinguishable0 qp)  ;STEP0  qp が区別可能か
            (let ((a (car qp)) (b (cadr qp)))
              (or (and (member a *fs*) (not (member b *fs*)))
                  (and (member b *fs*) (not (member a *fs*))))))
      
          (define (step0)
            (format #t "{\n\\large\\gt  Step1} \\\\ \n")
            (let ((qps (filter (lambda (x) (string-ci< (atom2str (car x)) (atom2str (cadr x)))) (dpro *qs* *qs*))))
              (set! *r* (filter distinguishable0 qps))
    
              (pmat3 *qs* *r*)
              (format #t "\\begin{minipage}{0.7\\hsize}\n 最終状態と非最終状態は入力がなくても区別できる")
              (format #t "\n\\end{minipage}\\\\ \\\\")
              (remove distinguishable0 (sort qps))
              ))
    
          (define (step1 qps)
            (format #t "{\\large\\gt  Step2 開始}\n\n")
            (for-each (lambda (y)
                        (let ((yy (normq y)))
                          (hr)
    ;                     (pmat3 *qs* *r*)
                          (pmat *qs* *r* (car yy) (cadr yy) (nextqsq yy))
                          
                          (format #t "\\begin{minipage}{0.7\\hsize}\n")
                          (format #t "$(~A \\: ~A )$\n\n" (car yy) (cadr yy))
                          (distinguishable1 yy)
                          (format #t "\\end{minipage}\n\n")
    
                          (pmat3 *qs* *r*)
                          (format #t "\\begin{minipage}{0.7\\hsize}\n")
                                  
                          (format #t "\\end{minipage}\n\n")
                          
                          ))
                      qps)
            *r*)
    
          (define (prql ql)
            (if (null? ql) (display "空")
                (for-each (lambda (x)
                        (prq (car x))
                        (format #t "$ \\to $")
                        (prq (cadr x))
                        (format #t "$ \\: $ ")
                        ) ql))
            (newline)
            )
    
          (define (prql2 ql)
            (if (null? ql) (display " 推移先は区別不可能が自明なので保留リストは変更しない\\\\ \n")
                (begin 
                  (for-each (lambda (x)
                        (prq (car x))
                        (format #t "$ \\to $")
                        (prq (cadr x))
                        (format #t "$ \\: $ ")
                        ) ql)
                  (format #t " を保留リストに追加\\\\ \n"))
            ))
    
          (define (chkpending qp)
            (display "現在の保留リスト " )
            (if (null? *p*) (print "空\\\\")
                (begin  (prql *p*)  (display "\\\\")))
            (let ((pl (filter (lambda (x) (equal? qp (cadr x)) ) *p*)))
              (if (null? pl)
                  (begin
                    (prql (list (list '(? ?) qp)))
                    (print "は保留リストにない"))
                  (for-each (lambda (y)
                              (set! *r* (cons (normq (car y)) *r*)) ; 区別可能リストに追加
                              (delpending (cadr y))
                              ) pl)
                  )))
          
          (define (adddistinguishable qp)
            (if (member qp *r*) *r* (set! *r* (cons qp *r*)))
            (chkpending qp)
            *r* )
    
          (define (addpending qp)
            (let ((pq (map (lambda (x) (list (normq qp) x))
                           (deldup (map normq (nextqsq qp))))))
              (set! *p* (deldup (deltrivpending (append pq *p*))))))
    
    
          (define (delpending qp)
            (let* ((bq (caar (filter (lambda (x) (equal? qp (cadr x))) *p*)))
                   (pq (remove (lambda (x) (equal? bq (car x))) *p*)))
    
              (set! *p* pq)
              (set! *r* (cons  bq *r*))
    
              (prql (list (list (normq bq) (normq qp))))
         
              (format #t "が保留リストにあり,保留の")
              (prq (normq bq))
              (format #t "が区別可能\\\\ \n")
              (prql (list (list (normq bq) '(? ?))))
              (format #t " を保留リストから除く\\\\ \n")
              (pbatsu bq) (newline)
    
              (prql (list (list '(? ?) (normq bq))))
              (format #t " が保留リストにあるかチェック\\\\ \n")
              (chkpending bq)
              ))
    
          (define (distinguishable1 qp)
            (let* ((nqs (map normq (nextqsq  qp)))
                   (result (filter (lambda (x) (member x *r*)) nqs)))
              (msg1 qp)
              (if (null? result)
                  (begin 
                    (addpending (normq qp))
                    (prql2 (deltrivpending  (map (lambda (x) (list (normq qp) x))(deldup (map normq (nextqsq qp))))))
    ;               (format #t " を保留リストに追加\\\\ \n")
                    (format #t "現在の保留リスト ")
                    (prql *p*)
                    )
                  (begin (pbatsu qp) (newline)
                         (adddistinguishable (normq qp))))))
    
    
          (define (rev-member? q l)
            (let ((r (list (cadr q) (car q))))
              (or (member q l) (member r l))))
    
          (define (pmat x d i j nq)
            (let ((h (drop-right x 1))
                  (v (cdr x))
                  (k (length x))
                  (l 2)
                  (c1 "")
                  (c2 "")
                  (c3 "")
                  )
              (newline)
              
              (format #t "\\begin{minipage}{0.3\\hsize}\n")
              (format #t "$\n\\begin{matrix}")
              (format #t "\\cline{1-~A}\n" l)
        
              (for-each (lambda (n)
                          (format #t "\\multicolumn{1}{|c|}{\\cellcolor[gray]{.9}~A}" n)
                          (for-each (lambda (m)
    ;                                (if (and (eq? j n) (eq? i m)) (set! c1 "{\\cellcolor[rgb]{0.65, 1.0, 0.65}") (set! c1 "{"))
    
                                     (if (and (eq? j n) (eq? i m))
                                         (set! c1 "{\\cellcolor[rgb]{0.85, 1.0, 1.0}") 
                                         (if (member (normq (list n m))  (map normq nq))
                                             (set! c1 "{\\cellcolor[rgb]{0.65, 1.0, 0.7}") (set! c1 "{")))
                                      
                                      (cond ((and (string-ci> (atom2str n) (atom2str m))
                                                  (rev-member? (list m n) d))
                                             (format #t " & \\multicolumn{1}{c|} ~A \\times} " c1))
                                            ((string-ci> (atom2str n) (atom2str m))
                                             (format #t " & \\multicolumn{1}{c|} ~A }" c1))
                                            ((equal? n m)
                                             (format #t " & \\multicolumn{~A}{c}{}" (- k l)))
                                            (else
                                             (display " ")
                                             ))
                                      
                                      ) h)
                          (if (< l k) (set! l (+ l 1)))
                          (format #t "\\\\ \\cline{1-~A}\n" l)
                          ) v)
              
              (format #t "\\multicolumn{1}{|c|}{}")
              (for-each (lambda (m)
                          (format #t "& \\multicolumn{1}{c|}{\\cellcolor[gray]{.9}~A}" m))
                        h)
              (format #t " \\\\ \\hline\n")
              (format #t "\\end{matrix}\n")
              (format #t "$ \\end{minipage}\n")
              d ))
    
    
          (define (pmat3 x d)
            (let ((h (drop-right x 1))
                  (v (cdr x))
                  (k (length x))
                  (l 2)
                  )
              (newline)
              
              (format #t "\\begin{minipage}{0.3\\hsize}\n")
              (format #t "$\n\\begin{matrix}")
              (format #t "\\cline{1-~A}\n" l)
        
              (for-each (lambda (n)
                          (format #t "\\multicolumn{1}{|c|}{\\cellcolor[gray]{.9}~A}" n)
                          (for-each (lambda (m)
                                      (cond ((and (string-ci> (atom2str n) (atom2str m))
                                                  (rev-member? (list m n) d))
                                             (format #t " & \\multicolumn{1}{c|}{\\times} "))
                                            ((string-ci> (atom2str n) (atom2str m))
                                             (format #t " & \\multicolumn{1}{c|}{ }"))
                                            ((equal? n m)
                                             (format #t " & \\multicolumn{~A}{c}{}" (- k l)))
                                            (else
                                             (display " ")
                                             ))
                                      ) h)
                          (if (< l k) (set! l (+ l 1)))
                          (format #t "\\\\ \\cline{1-~A}\n" l)
                          ) v)
              
              (format #t "\\multicolumn{1}{|c|}{}")
              (for-each (lambda (m)
                          (format #t "& \\multicolumn{1}{c|}{\\cellcolor[gray]{.9}~A}" m))
                        h)
              (format #t " \\\\ \\hline\n")
              (format #t "\\end{matrix}\n")
              (format #t "$ \\end{minipage}\n")
              d ))
    
          (define (step2)
            (remove (lambda (x) (member x *r*))
                    (remove  distinguishable0   (filter (lambda (x) (string-ci< (atom2str (car x)) (atom2str (cadr x))))
                                                        (dpro *qs* *qs*)))))
    
    ;      (define (reduce eqs)
    ;        (let ((d (map car eqs)))
    ;          (remove (lambda (x)
    ;                    (or (member (caar x) d) (member (cadr x) d))) *delta*)))
    
    
          (step1 (step0))
    ;     (pmat3 *qs* *r*)
    ;     (print (reduce M1 #?=(step1 (step0))))
    ;     (pmat *qs* *r* 'a 'b)
          (step2)
          ))
    
    (define (replaceall o n d)
      (cond ((null? d) ())
            ((list? (car d)) (cons (replaceall o n (car d)) (replaceall o n (cdr d))))
            ((eq? (car d) o) (cons n (replaceall o n (cdr d))))
            (else (cons (car d) (replaceall o n (cdr d))))))
    
    (define (reduce1 x y)
      (if (null? y) x (reduce1 (replaceall (caar y) (cadar y)  x) (cdr y))))
    
    (define (reduce dfa eqs)
    
      (define (cap s1 s2)
        (filter (lambda (x) (member x s2)) s1))
      
      (let* ((reqs (map reverse eqs))
             (*qs* (car dfa)) (*sigma* (cadr dfa)) (*delta* (caddr dfa)) (*ss* (cadddr dfa)) (*fs* (car (cddddr dfa)))
             (qs (sort (deldup (reduce1 *qs* reqs))))
             (delta (sort (deldup (reduce1 *delta* reqs))))
             (ss *ss*)
             (fs (sort (deldup (reduce1 *fs* reqs)))))
        (list qs *sigma* delta (if (member *ss* qs) *ss* (car (cap (car (filter (lambda (x) (member *ss* x)) reqs)) qs))) fs)
        ))
    
    (ptrfig M1)
    (print "\n\n")
    (define EQS (minimize M1))
    (print "\n\n")
    (define M3 (reduce M1 EQS))
    (hr)
    (display "{\\Large \\gt 等価な状態対:}")
    (for-each prq EQS)
    (print "\n\n")
    (display "{\\gt 最小化されたDFA:}")
    (print "\n")
    (ptrfig M3)
    
    
    • Public Snippets
    • Channels Snippets