working on it ...

Filters

Explore Public Snippets

Sort by

Found 478 snippets

    external by gdevanla  3  0  1  0

    Y-Combinator description in Racket

    Y-Combinator description in Racket: y-combinator-racket.rkt
    ;; lambda expression do not have any assignments
    ;; so we will use the form where there is not lambda expressions
    
    ((lambda ()
      (define (adder n) (+ n 1))
      (define (mult3 n) (* n 3))
      (mult3 (adder 10))
      ))
    
    ;; create make-adder and compose using higher-order functions
    
    ((lambda ()
      (define (make-adder a) (lambda (n) (+ n 1)))
      (define (mult3 n) (* n 3))
      (define (compose f g) (lambda (x) (f (g x))))
      ((compose mult3 (make-adder 1)) 10)))
    
    
    ;; tenants correspondence principle
    ;; introduce binding
    ;; wrapping a function
    ;; inlining
    
    ;; tenants correspondence principle
    ((lambda ()
      (define (make-adder a) (lambda (n) (+ n 1)))
      (define (mult3 n) ((lambda () (* n 3))))  ;; update due to Tenants corresponse principle
      (define (compose f g) ((lambda () (lambda (x) (f (g x)))))) ;;update with Tenants correpondence principle
      ((compose mult3 (make-adder 1)) 10)))
    
    
    ;; introduce a binding
    ;; wrapping a function
    ((lambda (x) (+ x  1)) 10)
    
    ((lambda ()
       (define (make-adder a) (lambda (n1) ((lambda (n) (+ n a)) n1))) ;; wrapping a function
       (define (mult3 n) ((lambda (n) (* n 3)) n))
       (define (compose f g) (
                              (lambda (v)
                                ((lambda () (lambda (x) (f (g x)))))) 1234)) ;; introduce binding
       ((compose mult3 (make-adder 1)) 10)))
    
    ;; inlining
    ((lambda ()
       ;;(define (make-adder) (lambda (a) (lambda (n1) ((lambda (n) (+ n a)) n1)))) ;; wrapping a function
       ;;(define (mult3 n) ((lambda (n) (* n 3)) n))
       (define (compose f g) (
                              (lambda (v)
                                ((lambda () (lambda (x) (f (g x)))))) 1234)) ;; introduce binding
       ((compose
         (lambda (n) (* n 3) n)
         ((lambda (a) (lambda (n1) ((lambda (n) (+ n a)) n1))) 1))
        10)))
    
    ;; inlinit compose
    ((lambda ()
       ;;(define (make-adder) (lambda (a) (lambda (n1) ((lambda (n) (+ n a)) n1)))) ;; wrapping a function
       ;;(define (mult3 n) ((lambda (n) (* n 3)) n))
       ;;(define (compose) (lambda (f g)
       ;;                       (lambda (v)
       ;;                         ((lambda () (lambda (x) (f (g x)))))) 1234)) ;; introduce binding
       (((lambda (f g)
          ((lambda (v)
             ((lambda () (lambda (x) (f (g x)))))) 1234))
         (lambda (n) (* n 10))
         ((lambda (a) (lambda (n1) ((lambda (n) (+ n a)) n1))) 20)) 40)))
           
    
    ((lambda ()
       (((lambda (f g)
           ((lambda (v)
              ((lambda () (lambda (x) (f (g x)))))) 1234))
         (lambda (x) (* x 10))
         (lambda (x) (+ x 20))) 40)))
    
    ((lambda (a) (lambda (n1) ((lambda (n) (+ n a)) n1))) 10) 
    
    

    external by euhmeuh  3  0  1  0

    Count the number of "if" in a given folder and save it in a csv file

    Count the number of "if" in a given folder and save it in a csv file: all-we-need-is-if
    #!/usr/bin/racket
    #lang racket
    
    (require
      racket/date
      (only-in srfi/19 string->date))
    
    (define (count-ifs folder)
      (string-trim
        (with-output-to-string
          (lambda ()
            (system (format "grep -ore 'if' ~a | wc -l" folder)
                    #:set-pwd? #t)))
        "\n"))
    
    (define (save-to-file filepath result)
      (call-with-output-file filepath #:mode 'text #:exists 'append
        (lambda (out)
          (displayln result out))))
    
    (define (format-result date folder count)
      (parameterize ([date-display-format 'iso-8601])
        (format "~a,'~a',~a;"
                (date->string date #t)
                folder
                count)))
    
    (define db-path (make-parameter #f))
    (define the-date (make-parameter (current-date)))
    
    (define folder
      (command-line
        #:program "all-we-need-is-if"
        #:once-each
        [("-d" "--database") path
                             "Path to the CSV file to populate"
                             (db-path path)]
        [("-f" "--fake-date") date-string
                              "Fake date to use instead of now"
                              (the-date (string->date date-string "~Y-~m-~dT~H:~M:~S"))]
        #:args ([folder "."])
        folder))
    
    (when folder
      (define result (format-result (the-date)
                                    folder
                                    (count-ifs folder)))
      (if (db-path)
        (save-to-file (db-path) result)
        (displayln result)))
    
    
    

    external by Darren_N  4  0  1  0

    Fun with Lenses, structs and net/url in Racket

    Fun with Lenses, structs and net/url in Racket: net-lens.rkt
    #lang racket/base
    
    (require json
             lens
             net/url
             net/url-string
             net/head
             racket/dict
             racket/string)
    
    (struct/lens status (version code text) #:transparent)
    (struct/lens response (status headers port) #:transparent)
    
    (define URL "https://httpbin.org/redirect/3")
    (define URL2 "http://infoscience.epfl.ch/record/169879/files/RMTrees.pdf")
    
    ;; GET url-string and return a response struct
    (define (get-url url-string)
      (define-values (port header)
        (get-pure-port/headers (string->url url-string) #:redirections 5
                               #:status? #t))
      (define status (parse-status (get-status header)))
      (define headers (headers->jsoneq (extract-all-fields header)))
      (response status headers port))
    
    ;; Convert dict into jsexpr? (hasheq)
    (define (headers->jsoneq header-dict)
      (for/hasheq ([hd header-dict])
        (values (string->symbol (car hd)) (string-trim (cdr hd)))))
    
    ;; Pull status string from beginning of header string
    (define (get-status header-string)
      (car (regexp-match #px"[\\w/ .]*" header-string)))
    
    ;; Convert status string into a struct
    (define (parse-status status-str)
      (define-values (version code text) (apply values (string-split status-str)))
      (status version code text))
    
    ;; Lenses
    (define get-content-type-lens
      (lens-compose (hash-ref-lens 'Content-Type) response-headers-lens))
    (define get-status-code-lens
      (lens-compose status-code-lens response-status-lens))
    
    ;; Use lenses on response structs
    (println (lens-view get-status-code-lens (get-url URL))) ; "200"
    (println (lens-view get-content-type-lens (get-url URL2))) ; "application/pdf"
    
    

    external by Jérôme Martin  3  0  1  0

    Generate a text file from an hexadecimal range

    Generate a text file from an hexadecimal range: text-generator.rkt
    #lang racket
    
    (call-with-output-file "data.txt" #:exists 'replace
      (lambda (out)
        (for ([i (in-range #xF101 #xF12D)])
          (write-char (integer->char i) out))))
    
    
    

    external by ruliana  2  0  1  0

    Example of new pattern for pattern matching in Racket

    Example of new pattern for pattern matching in Racket: example-of-new-pattern.rkt
    #lang racket
    
    (define-match-expander aba
      (syntax-rules ()
        [(aba a b) (list a b a)]))
    
    (define some-list (list 4 3 4))
    
    (match some-list
      [(aba x y) (printf "x = ~a, y = ~a\n" x y)])
    
    

    external by Milo  3  0  1  0

    More sophisticated lazy language with pattern matching & eval interleaved

    More sophisticated lazy language with pattern matching & eval interleaved: glorious-haskill-redex.rkt
    #lang racket/base
    (require redex)
    
    (define-language Haskill
      [x ::= variable-not-otherwise-mentioned]
      [ctor ::= cons null A B C #t #f]
    
      ; expressions
      [e ::=
         x
         ctor
         (e e ...)
         (fix (x) e)
         (λ (p ...) e)
         (case e [p e] ...)
         (match m e e)  ; note: used internally, not "surface syntax"
         undefined]
      [v ::=
         ctor
         (ctor e ...)
         (λ (p ...) e)]
    
      ; patterns
      [p ::= x ctor (ctor p ...)]
      [vp ::= ctor (ctor p ...)]
    
      ; matching terms
      [m ::=
         [p = e]
         (and m ...)
         (ok Σ)
         (fail)]
      [Σ ::= ([x e] ...)]
    
      ; expression reduction context
      [E ::=
         (match (in-hole M [vp = E]) e e)
         (E e ...)
         hole]
    
      ; match reduction context
      [M ::=
         (and (ok Σ) ... M m ...)
         hole]
    
      ; M inside E
      [EM ::= (in-hole E (match M e e))])
    
    (define-metafunction Haskill
      app* : (Σ ...) -> Σ
      [(app* (([x_i e_i] ...) ...)) ([x_i e_i] ... ...)])
    
    (define-metafunction Haskill
      subst* : Σ e -> e
      [(subst* () e) e]
      [(subst* ([x_1 e_1] [x_i e_i] ...) e)
       (subst* ([x_i e_i] ...) (substitute e x_1 e_1))])
    
    (define-metafunction Haskill
      split : vp v -> ([p e] ...) or #f
      [(split ctor_1 ctor_1) ()]
      [(split (ctor_1 p_i ..._n) (ctor_1 e_i ..._n)) ([p_i e_i] ...)]
      [(split _ _) #f])
    
    (define rr
      (reduction-relation Haskill
        #:domain e
    
        ;; evaluation
    
        (--> (in-hole E (fix (x) e))
             (in-hole E (substitute e x (fix (x) e)))
             "E-fix")
    
        (--> (in-hole E ((λ (p_i ..._n) e) e_i ..._n))
             (in-hole E (match (and [p_i = e_i] ...) e undefined))
             "E-beta")
    
        (--> (in-hole E (case e [p_1 e_1] [p_i e_i] ...))
             (in-hole E (match [p_1 = e] e_1 (case e [p_i e_i] ...)))
             "E-case")
    
        (--> (in-hole E (case e))
             (in-hole E undefined)
             "E-case-mt")
    
        (--> (in-hole E (match (ok Σ) e_1 e_2))
             (in-hole E (subst* Σ e_1))
             "E-ok")
    
        (--> (in-hole E (match (fail) e_1 e_2))
             (in-hole E e_2)
             "E-fail")
    
    
        ;; pattern matching
    
        (--> (in-hole EM [x = e])
             (in-hole EM (ok ([x e])))
             "M-bind")
    
        (--> (in-hole EM [vp = v])
             (in-hole EM (and [p_i = e_i] ...))
             "M-split"
             (where ([p_i e_i] ...) (split vp v)))
    
        (--> (in-hole EM [vp = v])
             (in-hole EM (fail))
             "M-fail"
             (where #f (split vp v)))
    
        (--> (in-hole EM (and (ok Σ_i) ...))
             (in-hole EM (ok (app* (Σ_i ...))))
             "M-ok*")
    
        (--> (in-hole EM (and (ok Σ_i) ... (fail) m ...))
             (in-hole EM (fail))
             "M-fail*")
    
        ))
    
    
    

    external by Joshua Herman  4  0  1  0

    Partial prototype of a knot theory POW.

    Partial prototype of a knot theory POW.: knot-theory-POW.rkt
    #! /usr/bin/env racket
    
    #lang typed/racket #:with-refinements
    ;(require graph)
    ;raco pkg install graph
    (require typed/racket/date)
    (require racket/sequence)
    (require typed/racket/date)
    (require math/array)
    (require math/matrix)
    
    (require typed/racket/unit)
    (require pfds/queue/hood-melville)
     
    
    
    (define trefoil (array #[#[00 02 01 00]
                             #[02 10 09 01]
                             #[03 09 04 06]
                             #[00 03 05 04]] : Integer))
    (define simple-unknot (array #[#[02 01 ]
                                   #[03 04]] : Integer))
    
    
    ;TODO It must have a dimention of N by M
    ;TODO It must be ambiend isotopic to the knot $K$ that we send
    ;TODO It must have a set of operations $O$ of cardinality $O_n$
    ;DONE It must have a crossing number $C$
    ;TODO use a queue (set? ) and a set of mosaic moves to implement the checking of validity of a set of moves.
    ;source is optional
    ; Knot table
    ;KNOTS are specified as a $N * M$ matrix corresponding to $0-18$ that maps to the set of mosaic tiles $T_0$ to $T_n$
    
    ;(define culprit (matrix-graph [[0 3 8 #f -4]
    ;                           [#f 0 #f 1 7]
    ;                           [#f 4 0 #f #f]
    ;                           [2 #f -5 0 #f]
    ;                           [#f #f #f 6 0]]))
    ; https://docs.racket-lang.org/math/matrix_types.html#%28form._%28%28lib._math%2Fmatrix..rkt%29._.Matrix%29%29
    (struct braidcoin ([source_knot : (Matrix Integer)]
                       [target_knot : (Matrix Integer)]
                       [crossing_number : (Refine [n : Integer] (> n 0))]
                       [dimention : (Refine [n : Integer] (> n 0))]
                       [timestamp : date])
      #:prefab)
    (define unknot-trefoil (braidcoin trefoil simple-unknot 3 4 (current-date)))
    (define unknot-unknot (braidcoin simple-unknot simple-unknot 3 4 (current-date)))
    
    
    ;* Header X-braidcoin: 0:SOURCE_KNOT:DESTINATION_KNOT:CROSSING_NUMBER:DIMENTION:OPERATION_COUNTER:DATE
    
    ;KNOTS are specified as a $N * M$ matrix corresponding to $0-18$ that maps to the set of mosaic tiles $T_0$ to $T_n$
    (struct knot-operations ([queue : braidcoin]))
    (: crossing-number (-> (Array Integer) Integer))
    (define (crossing-number array)
      ;09 and 10 correspond to over and under crossing
      (array-count (λ: ([x : Integer]) (or (equal? x 10) (equal? x 09))) array))
    (: crossing-number-test (-> braidcoin Boolean))
    (define (crossing-number-test bc)
      ;DONE It must have a crossing number $C$
      (if (equal? (crossing-number (braidcoin-source_knot bc))
                  (crossing-number (braidcoin-target_knot bc)))
          #t
          #f))
    ;(struct knot-operations braidcoin) 
    ;(define (expansion move braidcoin)
    ;  #t)
    ;(define (reidmeister-1 braidcoin)
    ;  #t)
    
    
    (define-type Tree (U leaf node))
    
    (struct leaf  ([source_knot : (Matrix Integer)]
                       [target_knot : (Matrix Integer)]
                       [crossing_number : (Refine [n : Integer] (> n 0))]
                       [dimention : (Refine [n : Integer] (> n 0))]
                       [timestamp : date])
      #:prefab)
    (struct node ([left : Tree] [right : Tree]))
     
    (: tree-height (-> Tree Integer))
    (define (tree-height t)
      (cond [(leaf? t) 1]
            [else (max (+ 1 (tree-height (node-left t)))
                       (+ 1 (tree-height (node-right t))))]))
    
    (define unknot-trefoil-leaf (leaf trefoil simple-unknot 3 4 (current-date)))
    (define unknot-unknot-leaf (leaf simple-unknot simple-unknot 3 4 (current-date)))
    (tree-height (node unknot-unknot-leaf unknot-trefoil-leaf))
    (node unknot-unknot-leaf unknot-trefoil-leaf)
    (tree-height (node unknot-unknot-leaf unknot-trefoil-leaf))
    
    ;(: test-fail (-> Tree Boolean))
    ;(define (tree-height t)
    ;  (cond [eqv? (crossing-number (node-left t)) (node-right t) #f]
    ;        [else (max (+ 1 (tree-height (node-left t)))
    ;                   (+ 1 (tree-height (node-right t))))]))
    
    
    ;(struct queue)
    ;(struct chain)
    ;(struct current_transactions)
    
    

    external by Tony Colston  10  0  1  0

    racket aoc2017.1

    racket aoc2017.1: aoc2017.1.rkt
    #lang racket
    
    (define (chk s)
      (println s)
      (let ([f (first s)]
              [g (first (rest s))])
        (printf "~a ~a\n" f g)
          )
      )
    
    (define (precheck s)
      (chk (string->list s))
      )
    
    (precheck "1122")
    
    

    external by World2LiveBy  8  0  1  0

    Basic implementation of Church Numerals and Compound date in Scheme utilizing lambda calculus

    Basic implementation of Church Numerals and Compound date in Scheme utilizing lambda calculus: LambdaPractice.rkt
    #lang scheme
    
    ;;---Lambda Calculus---
    
    (define I
      (λ (x) x))
    
    (define K
      (λ (x) (λ (y) x)))
    
    (define KI
      (λ (x) ((K I) x)))
    
    (define V
      (λ (x) (λ (y) (λ (f) ((f x) y)))))
    
    ;;---Constructor and Selector Functions---
    
    (define cons
      (λ (x y) ((V x) y)))
    
    (define car
      (λ (l) (l K)))
    
    (define cdr
      (λ (l) (l KI)))
    
    ;;---Church Numerals and Arithmetic---
    
    (define zero
      (λ (f) (λ (x) x)))
    
    (define succ
      (λ (n)
        (λ (f) (λ (x)
                 (f ((n f) x))))))
    
    (define add
      (λ (m) (λ (n)
               (λ (f) (λ (x)
                        ((m f) ((n f) x)))))))
    
    (define one   (λ (f) (λ (x) (f  x))))
    (define two   (λ (f) (λ (x) (f (f  x)))))
    (define three (λ (f) (λ (x) (f (f (f  x))))))
    
    ;;---Printing and Output Functions---
    
    (define printPair
      (λ (p) (begin
               newline
               (display "(")
               (display (car p))
               (display ",")
               (display (cdr p))
               (display ")"))))
    
    (define printNumeral
      (λ (n) (display 
              ((n (λ (x) (+ x 1))) 0))))
    
    
    

    external by euhmeuh  8  0  1  0

    Accessible minimal website

    Accessible minimal website: serverlet.rkt
    #lang racket/base
    
    (require web-server/servlet
             web-server/servlet-env)
     
    (define (start req)
      (response/xexpr
       `(html ([lang "en"])
              (meta ([charset "utf-8"]))
              (meta ([name "viewport"]
                     [content "width=device-width, initial-scale=1.0, shrink-to-fit=no"]))
              (head (title "Hello world!")
                    (style ([type "text/css"])
                           "@keyframes focus {0% {outline: 1px solid; outline-offset: 1em;} 100% {outline: 6px solid; outline-offset: .10em;}}"
                           "a:focus {outline: 6px solid; outline-offset: .10em; animation: focus .15s}"
                           "html {font-family: Fira Code;}"
                           "body {min-width: 26ch; max-width: 60ch; width: 100%; margin: 0 auto;}"
                           "aside {width: 50%; float: right;}"
                           "aside p {margin: 10px; text-align: right;}"
                           "p {text-align: justify;}"))
              (body (header (h1 "Vegetables & Fruits"))
                    (nav (ul
                           (li (a ([href "#vegetables"]) "Vegetables"))
                           (li (a ([href "#fruits"]) "Fruits"))
                           (li (a ([href "#about"]) "About"))))
                    (main
                      (article
                        (h2 ([id "vegetables"]) "Vegetables")
                        (p "I love vegetables.")
                        (p "abcdefghijklmnopqrstuvwxyz")
                        (p "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefgh")
                        (h3 "Especially")
                        (p "Bla bla bla...")
                        (p "Bla bla."))
                      (article
                        (h2 ([id "fruits"]) "Fruits")
                        (p "I also like fruits.")
                        (h3 "Especially")
                        (p "Lorem ipsum dolor sit amet, consectetur adipiscing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. "
                           "Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat.")
                        (aside (p "Note to self: add some content here."))
                        (p "Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. "
                           "Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.")))
                    (footer
                      (h2 ([id "about"]) "About us")
                      (p "We like vegetables and fruits")
                      (hr)
                      (p "Copyright Blabla, Inc. All rights reserved."))))))
     
    (serve/servlet start)
    
    
    
    • Public Snippets
    • Channels Snippets