Skip to content

Instantly share code, notes, and snippets.

@include-yy

include-yy/README.org

Last active January 13, 2025 08:15
Show Gist options

  • Select an option

    Learn more about clone URLs
  • Save include-yy/9c8929babb5bd7c18f41242548da1d25 to your computer and use it in GitHub Desktop.

Select an option

Learn more about clone URLs
Save include-yy/9c8929babb5bd7c18f41242548da1d25 to your computer and use it in GitHub Desktop.
Download ZIP
Simple CPS Monad written in Racket
Raw
README.org

CPS monads in Racket

在 Racket 中实现一些简单的 Monad。

Raw
a.rkt
#lang racket
(define (Rc x) (λ (k) (k x)))
(define (Kc x) (λ (k) (k x)))
(define (Cc m f) (m f))
(define (Gc m f) (m f))
(define +* (λ (a) (Rc (λ (b) (Rc (+ a b))))))
(define -* (λ (a) (Rc (λ (b) (Rc (- a b))))))
(define ** (λ (a) (Rc (λ (b) (Rc (* a b))))))
(define /* (λ (a) (Rc (λ (b) (Rc (/ a b))))))
(Gc (Gc
(Cc (Gc (Cc (Gc (Cc (Rc 2) **) (Kc 3)) +*) (Kc 3)) +*)
(Gc (Cc (Gc (Cc (Rc 3) /*) (Kc 3)) -*) (Kc 1)))
identity)
Raw
b.rkt
#lang racket
(define (Rc x) (λ (k) (k x)))
(define (Kc x) (λ (k) (k x)))
(define (Cc m f) (m f))
(define (Gc m f) (m f))
(define +* (λ (a) (λ (b) (Rc (+ a b)))))
(define -* (λ (a) (λ (b) (Rc (- a b)))))
(define ** (λ (a) (λ (b) (Rc (* a b)))))
(define /* (λ (a) (λ (b) (Rc (/ a b)))))
(Gc (Cc (Cc ((** 2) 3) (λ (x) ((+* x) 3)))
(λ (v1)
(Cc (Cc ((/* 3) 3) (λ (x) ((-* x) 1)))
(λ (v2) (Rc (+ v1 v2))))))
identity)
Raw
c.rkt
#lang racket
(module Cont racket
(define Cont%? (λ (x) (is-a? x Cont%)))
(define Cont%
(class object%
(super-new)
(init-field value)
(define (call f) (value f))
(define (call2 f) (value f))
(public [call bindM] [call2 get])))
(define (Rc x) (instantiate Cont% [(λ (k) (k x))]))
(define (Cc m f) (send m bindM f))
(define (Gc m f) (send m get f))
(define (Kc x) (λ (k) (k x)))
(provide
(contract-out
[Cc (-> Cont%? (-> any/c Cont%?) Cont%?)]
[Gc (-> Cont%? (-> any/c any/c) any/c)])
Kc Rc))
(require 'Cont)
(define +* (λ (a) (Rc (λ (b) (Rc (+ a b))))))
(define -* (λ (a) (Rc (λ (b) (Rc (- a b))))))
(define ** (λ (a) (Rc (λ (b) (Rc (* a b))))))
(define /* (λ (a) (Rc (λ (b) (Rc (/ a b))))))
(Gc (Gc (Cc (Gc (Cc (Gc (Cc (Rc 2) **) (Kc 3)) +*) (Kc 3)) +*)
(Gc (Gc (Cc (Gc (Cc (Rc 3) /*) (Kc 3)) -*) (Kc 1)) Kc))
identity)
(define +** (λ (a) (λ (b) (Rc (+ a b)))))
(define -** (λ (a) (λ (b) (Rc (- a b)))))
(define *** (λ (a) (λ (b) (Rc (* a b)))))
(define /** (λ (a) (λ (b) (Rc (/ a b)))))
(Gc (Gc (Cc ((*** 2) 3) (λ (x) ((+** x) 3)))
(λ (x) (Gc (Cc ((/** 3) 3) (λ (x) ((-** x) 1))) (+** x))))
identity)
(Gc (Cc (Cc ((*** 2) 3) (λ (x) ((+** x) 3)))
(λ (v1)
(Cc (Cc ((/** 3) 3) (λ (x) ((-** x) 1)))
(λ (v2) (Rc (+ v1 v2))))))
identity)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment