Vag's List

Death of Rabbit (17350)

2011-10-27T10:53:00.000-07:00

GHC DO syntax desugaring is very intuitive and conforming

2010-03-11T06:40:00.000-08:00

{-# LANGUAGE NoImplicitPrelude #-} module Main where
import Prelude (putStrLn, (+), (*), show)

return a = a
infix 1 >>=; a >>= b = b a
infix 1 >>; a >> b = b a
fail a = a
fromInteger a = a

test = do
x <- return 1
y <- return 2
test2 x 10
test3 y

test2 a b = a + b
test3 a b = a * b

main = putStrLn (show test)

Lazy list division (Haskell)

2010-02-25T03:58:00.001-08:00


firstHalf :: [a] -> [a]
firstHalf list0 = div list0 list0
    where
    div (a,b:arg) (r:res) = r:div arg res
    div _ _ = []

Tiny proof assistant in Clean without Curry-Howard Isomorphism

2009-07-09T01:54:00.000-07:00


module PublishND

import StdGeneric, GenEq, StdMisc
from StdEnv import
 instance == {#Char}, instance == Int, instance == Real,
 &&, class == (..), instance == [a] | == a

Start = let p = pvar "P" in [notI2 p,notE2_nc p,notE3 p,notE3_nc p,errNotE2 p]
where
 impOpen r p = impE r (assum p)
 mix a b
  # r = andI a b
  # r = andE r
  = r
 mix` a b
  # r = andI a b
  # r = andE` r
  = r
 /*
        p, p -> _|_ |- _|_
  -----------------------------
   p |- (p -> _|_) -> _|_
 */
 notI2 p
  # a = assum p
  # b = assum (p --> B)
  # r = mix` a b
  # r = impOpen r p
  # r = impI r (p --> B)
  = r

 /*
  ~p,~~p |- ~p /\ ~~p
  --------------- assum(~p),assum(~~p),andI,contra,absurd(p)
   ~p
 */
 notE2_nc p // !!!!!! [!] !!!!!!!
  # np = ~ p
  # nnp = ~ np
  # a = assum np
  # b = assum nnp
  # r = contra a b
  # r = absurd r p
  = r

 /*
   P |- (P --> _|_) --> _|_
   ((P --> _|_) --> _|_) --> _|_ |- ((P --> _|_) --> _|_) --> _|_
   ((P --> _|_) --> _|_) --> _|_, P |- _|_
  -------------------------------------------------
   ((P --> _|_) --> _|_) --> _|_ |- P --> _|_
 */
 notE3 p
  # n3 = ((p --> B) --> B) --> B
  # a = notI2 p
  # b = assum n3
  # r = contra a b
  # r = impI r p
  = r

 notE3_nc p
  # np = ~ p
  # nnp = ~ np
  # nnnp = ~ nnp
  # a = assum nnp
  # b = assum nnnp
  # r = contra a b
  # r = absurd r np
  = r

 /* doubleNot:
  ~~~p,p,... |- q /\ ~q
  ------------- weak(p),contra,notI3,absurd
   p |- ~~p
 */
 errNotE2 p
  # np = ~ p
  # nnp = ~ np
  # nnnp = ~ nnp
  # r = assum (nnp /\ nnnp)
  # a = andE r
  # b = andE` r
  # r = contra a b
  // r = absurd r nnp
  = r

pvar a = PV a
tvar a = TV a

/* ----------------- TCB (so must be in separate module with ::Deduced as abstract type ----------------------- */

start => EMPTY |- T
assum p => p$ EMPTY WITH p |- p
weak (v |- p) q => q$ v WITH q |- p
impI (v |- p) q | q IN v => q$ v WITHOUT q |- q --> p
impE (v |- p --> q) (w |- p`) | p == p` => v AND w |- q
andI (v |- p) (w |- q) => v AND w |- p /\ q
andE (v |- p /\ q) => v |- p
andE` (v |- p /\ q) => v |- q
orI (v |- p) q => p$ v |- p \/ q
orI` (v |- p) q => q$ v |- q \/ p
orE (v |- r) (w |- r`) (y |- p /\ q) | r == r` && p IN v && q IN w => (v WITHOUT p) AND (w WITHOUT q) AND y |- r
//notI (v |- p) => v |- ~ (~ p)
contra (v |- p) (w |- ~p`) | p == p` => v AND w |- B
contra (v |- p) (w |- p` --> B) | p == p` => v AND w |- B
/* --------- NONCONSTRUCTIVE PART --------------- */
absurd (v |- B) p | ~p IN v => p$ v WITHOUT ~p |- p
botE (v |- B) p => p$ v |- p
midE p => p$ EMPTY |- p \/ ~p

:: Deduced
 = (|-) infix 1 (Set Prop) Prop

/* -------------------------------------------- END OF TCB ------------------------------------- */

:: Prop
 = (====) infix 4 Term Term | (<) infix 4 Term Term | (>) infix 4 Term Term
 | (=<) infix 4 Term Term | (>=) infix 4 Term Term | (-->) infix 5 Prop Prop
    | (<--) infix 5 Prop Prop | (<->) infix 5 Prop Prop | (\/) infixr 6 Prop Prop
    | (/\) infixr 6 Prop Prop | ~ Prop | A [String] Prop | E [String] Prop
    | B /* bottom */ | T /* truth */ | PV String

derive gEq Prop ; instance == Prop where (==) a b = gEq{|*|} a b

:: Term
 = I Int | F Real | S String | C String | TV String | (+) infixl 6 Term Term
 | (-) infixl 6 Term Term | (*) infixl 7 Term Term | (/) infixl 7 Term Term
 | (%) infixl 9 Term Term | (++) infixr 5 Term Term | (^) infixr 8 Term Term

derive gEq Term ; instance == Term where (==) a b = gEq{|*|} a b

:: Set a :== [a]

EMPTY = []
(WITH) infixl 3 :: [Prop] Prop -> [Prop]
(WITH) w p = [p:w WITHOUT p]
(WITHOUT) infixl 3 :: [Prop] Prop -> [Prop]
(WITHOUT) [w:ws] p | w == p = ws ; = [w:ws WITHOUT p]
(WITHOUT) [] _ = []
(AND) infixl 2 :: [Prop] [Prop] -> [Prop]
(AND) w [v:vs] = (w WITH v) AND vs // remove pars?
(AND) w [] = w
(IN) infix 9 :: Prop [Prop] -> Bool
(IN) p [w:ws] | w == p = True ; = p IN ws
(IN) _ [] = False

($) infixr 0 :: Prop a -> a
($) p r | valid p = r ; = abort "SYNTAX"
valid a = True

Tiny proof assistant in Clean using Curry-Howard Isomorphism

2009-07-09T01:47:00.000-07:00


module CHI

Start = notE3 (|- (((P --> Bot) --> Bot) --> Bot)) (Wff P)  //notI2 (|- P) (Wff P)
where
 notE3 n3 wff_p = impI (hlp1 n3) wff_p
 where
  hlp1 n3 p = nd_contra (notI2 p wff_p) n3

 notI2 p wff_p = impI (hlp p) (nd_not wff_p)
 where
  hlp p pb = impE pb p

 nd_contra p pb = contra p (nd_not_def` pb)
 nd_not wff_p = wff_imp wff_p wff_bot

/* ======================== TCB ========================== */

/* must be hidden in separate module */

/* ------- SYNTAX --------- */

wff_a :: Wff CstA ; wff_a = Wff A ; wff_b :: Wff CstB ; wff_b = Wff B ; wff_p :: Wff CstP ; wff_p = Wff P
wff_c :: Wff CstC ; wff_c = Wff C ; wff_d :: Wff CstD ; wff_d = Wff D ; wff_q :: Wff CstQ ; wff_q = Wff Q

wff_bot :: Wff Bot
wff_bot = Wff Bot

wff_true :: Wff TRUE
wff_true = Wff TRUE

wff_not :: (Wff p) -> Wff (Not p)
wff_not (Wff p) => Wff (~ p)

wff_and :: (Wff p) (Wff q) -> Wff (And p q)
wff_and (Wff p) (Wff q) => Wff (p /\ q)

wff_or :: (Wff p) (Wff q) -> Wff (Or p q)
wff_or (Wff p) (Wff q) => Wff (p \/ q)

wff_imp :: (Wff p) (Wff q) -> Wff (Imp p q)
wff_imp (Wff p) (Wff q) => Wff (p --> q)

/* ----------- CONSTRUCTIVE ---------- */

impI :: ((Deduced p) -> Deduced q) (Wff p) -> Deduced (Imp p q)
impI f (Wff p) => case f (|- p) of |- q -> |- (p --> q)

impE :: (Deduced (Imp p q)) (Deduced p) -> Deduced q
impE (|- (p --> q)) (|- p`) => |- q

andI :: (Deduced p) (Deduced q) -> Deduced (And p q)
andI (|- p) (|- q) => |- (p /\ q)

andE :: (Deduced (And p q)) -> Deduced p
andE (|- (p /\ q)) => |- p

andE` :: (Deduced (And p q)) -> Deduced q
andE` (|- (p /\ q)) => |- q

orI :: (Deduced p) (Wff q) -> Deduced (Or p q)
orI (|- p) (Wff q) => |- (p \/ q)

orI` :: (Deduced p) (Wff q) -> Deduced (Or p q)
orI` (|- p) (Wff q) => |- (p \/ q)

contra :: (Deduced p) (Deduced (Not p)) -> Deduced Bot
contra (|- p) (|- (~ q)) => |- Bot

mp p q = impE p q
nd_not_def (|- (~ p) ) = |- (p --> Bot)
nd_not_def` (|- (p --> Bot)) = |- (~ p)

/* ----------- NONCONSTRUCTIVE (move to separate module) --------- */

absurd :: ((Deduced (Not p)) -> Deduced Bot) (Wff p) -> Deduced p
absurd _ (Wff p) => |- p

bottom_complete :: (Deduced Bot) (Wff p) -> Deduced p
bottom_complete (|- Bot) (Wff p) => |- p

tertium :: (Wff p) -> Deduced (Or p (Not p))
tertium (Wff p) => |- (p \/ ~ p)

:: Deduced p = |- p /* *MUST* be abstract type! */

:: Wff a = Wff a /* *MUST* be abstract type! */

/* ======================== END OF TCB ========================== */

:: CstA = A ; :: CstB = B ; :: CstC = C ; :: CstD = D ; :: CstE = E ; :: CstP = P ; :: CstQ = Q
:: Not a = ~ a
:: Imp a b = (-->) infix 5 a b
:: And a b = (/\) infixr 6 a b
:: Or a b = (\/) infixr 6 a b
:: Bot = Bot
:: TRUE = TRUE

Read Only True Graph Builder In Functional Language

2009-03-03T01:50:00.000-08:00



:: ROGraph a = ROGraph a [ROGraph a]
:: RODGraph a = RODGraph a [RODGraph a] [RODGraph a]

buildROGraph :: (a b (c,[b])) -> Map b (ROGraph c) | Lookup MapOnList b & UpdateDefault MapOnList b & Pairs a
buildROGraph m = buildGraph m \ id val fws bws = ROGraph val fws
buildRODGraph m = buildGraph m \ id val fws bws = RODGraph val fws bws

buildGraph rawGraph constructor = futureIndex
where
 raw = pairs rawGraph
 forwards = buildFastMap $ flip map raw \ (id,(a,fws)) = (id,fws)
 backwards = buildBackwards forwards
 futureIndex = buildFastMap $ flip map raw \ (id,(a,fws)) = (id,build id a fws)
 fromFuture ids = map (fromJustXXX o lookup futureIndex) ids
 build nodeId contents forwards
  # backwards = case lookup backwards nodeId of Just x -> x ; _ -> []
  = constructor nodeId contents (fromFuture forwards) (fromFuture backwards)

buildBackwards :: (a b [c]) -> a c [b] | Empty (a c [b]) & Pairs a & UpdateDefault a c
buildBackwards graph = seqMap processNode (pairs graph) empty
where
 processNode (id,forwards) = seqMapLFA forwards \ fr m = snd $ updateDefault fr (cons id) [] m

testGraph :: Map Int (Int,[Int])
testGraph = fromPairs [ @1 [2,3,4], @2 [4,1], @3 [1,2], @4 [3,4] ]
where
 @ a b = (a,(a,b))

Start = printRODGraph $ fromJust $ lookup (buildRODGraph testGraph) 1

Adding Pluggable Search Strategies to Your Favourite Functional Programming Language

2009-01-17T17:55:00.000-08:00


search3 :: !Bool !(u:a -> .(v:([u:a] -> w:[.b]) -> x:[.b])) u:a -> y:[.b], [v <= u,x v <= w,x v <= y]
search3 kind explorer root
 | kind = do_all_depth [root] []
 = do_all_breadth [root] []
where
 do_all_depth [] t = t
 do_all_depth [v:vs] t = explorer v \ vs` = do_all_depth vs` (do_all_depth vs t)
    
 do_all_breadth [] t = t
 do_all_breadth [v:vs] t = explorer v \ vs` = do_all_breadth vs (do_all_breadth vs` t)

Purely Functional Queue with Constant Operation Times (Credits to Okasaki)

2009-01-15T19:55:00.000-08:00


:: Queue a = Queue !Int !.[a] !Int !.[.[a]] /* enqLen enqList deqLen deqList */

adjust :: !u:(Queue .a) -> v:(Queue .a), [u <= v]
adjust q=:(Queue enqLen enqList deqLen deqList)
 | enqLen > 3 && enqLen >= deqLen = Queue 0 [] (enqLen + deqLen) (deqList ++ [reverse enqList])
 | otherwise = q

enq :: .a !u:(Queue .a) -> v:(Queue .a), [u <= v]
enq a (Queue enqLen enqList deqLen deqList)
 = adjust (Queue (enqLen + 1) [a:enqList] deqLen deqList)

deq :: !u:(Queue .a) -> (.a, !v:(Queue .a)), [u <= v]

deq (Queue enqLen enqList deqLen [[]:deqList])
 = deq (Queue enqLen enqList deqLen deqList)

deq (Queue enqLen enqList deqLen [[a:as]:deqList])
 = (a, adjust (Queue enqLen enqList (deqLen - 1) [as:deqList]))

deq (Queue enqLen enqList 0 deqList)
 = deq (Queue 0 [] enqLen [reverse enqList])

newq :: .(Queue .a)
newq = Queue 0 [] 0 []

emptyq :: !.(Queue .a) -> .Bool
emptyq (Queue 0 _ 0 _) = True
emptyq _ = False

Introductory Course In Math: No Background Needed

2008-11-11T00:30:00.000-08:00

1. Notion of representation
2. Notion of encoding
3. Requirements to glyphs: equality, recognisability, one might always realise where one ends and another begins
4. Deductive apparatus, mathematical theories
5. Interpretations of mathematical theories, constants
6. Variables, historic excursion into prop calc, difference between variables and constants; quantors; variable substitution and its pitfalls
7. What is Existence
8. What is Truth
9. Art of proof
10. Soundness, completeness, consistency
11. Proof theory
12. Model theory

(12 lessons, first two or three are short and may be conducted together)

Monadic Arithmetics

2008-09-25T07:48:00.000-07:00

/* Stop >>= \a -> >>= \b insane! */

instance + (m a) | + a & Monad m
where
 (+) ma mb = ma >>= \a -> mb >>= \b -> return $! a + b

instance - (m a) | - a & Monad m
where
 (-) ma mb = ma >>= \a -> mb >>= \b -> return $! a - b

instance * (m a) | * a & Monad m
where
 (*) ma mb = ma >>= \a -> mb >>= \b -> return $! a * b

instance / (m a) | / a & Monad m
where
 (/) ma mb = ma >>= \a -> mb >>= \b -> return $! a / b

instance mod (m a) | mod a & Monad m
where
 (mod) ma mb = ma >>= \a -> mb >>= \b -> return $! a mod b

instance rem (m a) | rem a & Monad m
where
 (rem) ma mb = ma >>= \a -> mb >>= \b -> return $! a rem b

/* http://hpaste.org/10673 */

Heterogeneous lists for poor Concurrent Clean programmer

2008-09-14T04:15:00.000-07:00

module sh /* search hlist */

import Same, FuncPipe, UnitType, UndefValue, Float, ErrorValue, Char, Logical, String
import Map, FPToolbox

Start = test2

//////////////////////////////

:: O = O
:: I a = I a

pos0 = O
add1 a = I a
add2 a = I (I a)
add3 a = I (I (I a))
pos1 = add1 pos0
pos2 = add2 pos0
pos3 = add3 pos0
pos4 = add1 pos3
pos5 = add2 pos4
pos6 = add3 pos3
pos7 = add3 pos4
pos8 = add3 pos5

///////////////////////////////////////////////////////

test2 :: String
test2 = selectHList pos0 ("hello",(-15.84,(100,(True,<>))))

class SelectHList i a t
where
 selectHList :: i a -> t

instance SelectHList (I i) (a,b) t | SelectHList i b t
where
 selectHList (I i) (a,b) = selectHList i b

instance SelectHList O (a,b) a` | Same a a`
where
 selectHList O (a,b) = same a

////////////////////////////////////////////////////

test :: String
test = searchHList ("hello",(-15.84,(100,(True,<>))))

class SearchHList t a
where
 searchHList :: !a -> t

instance SearchHList t <>
where
 searchHList <> = error "SearchHList: type not found!"

instance SearchHList t (a,b) | IfTypeEqual t a & SearchHList t b // allways inline this instance
where
 searchHList (a,b) = ifTypeEqual a $ searchHList b

class IfTypeEqual t a
where
 ifTypeEqual :: a t -> t

instance IfTypeEqual Int Int  where ifTypeEqual a b = a
instance IfTypeEqual Bool Bool  where ifTypeEqual a b = a
instance IfTypeEqual Float Float where ifTypeEqual a b = a
instance IfTypeEqual Char Char  where ifTypeEqual a b = a
instance IfTypeEqual String String where ifTypeEqual a b = a
instance IfTypeEqual [t] [a] | IfTypeEqual t a
where
 ifTypeEqual a b = map (\(ae,be) -> ifTypeEqual ae be) $ zip2 a b

instance IfTypeEqual t a where ifTypeEqual a f = f

My Desktop 2008

2008-07-24T10:04:00.000-07:00

Laziness without laziness

2008-06-06T10:43:00.001-07:00


foldM_ f xs = fold (\a e -> a >> f e) (return ()) xs

Instead of making chain of dynamically created functions from data list it is better to create a function that makes next function in chain


foldM_ f l = foldLoop l
where
        foldLoop []     = return ()
 foldLoop [x:xs] = f x >> foldLoop xs

Notice that this fragment does not use any language laziness.

2*n+h n Solution for Breadth-First Numbering (Okasaki paper)

2008-06-03T07:30:00.000-07:00


data Tree a = Tree a (Tree a) (Tree a) | Leaf a | EmptyLeaf
 deriving (Show,Eq)

renameTreeNodes :: (Tree a) -> [Int] -> (Tree Int)
renameTreeNodes tree counts     = fst $ renameLoop tree counts
 where
 renameLoop EmptyLeaf   cs    = (EmptyLeaf, cs)
 renameLoop (Leaf _)   (c:cs)   = (Leaf c, (c+1):cs)
 renameLoop (Tree _ lb rb) (c:cs)   = (Tree c lb' rb', (c+1):csLR)
  where
  (lb',csL) = renameLoop lb cs
  (rb',csLR) = renameLoop rb csL

countsToBases :: [Int] -> [Int]
countsToBases cs = ctbLoop cs 1
 where
 ctbLoop [c] b  = [b]
 ctbLoop (c:cs) b = b:ctbLoop cs (b + c)

countOnEachLevel :: (Tree a) -> [Int]
countOnEachLevel tree = countLoop tree []
 where
 countLoop EmptyLeaf counts = counts
 countLoop (Leaf _) (c:cs) = (c+1):cs
 countLoop tree []  = countLoop tree [0]
 countLoop (Tree _ leftBranch rightBranch) (c:cs) = (c+1):csLR
  where
  csL = countLoop leftBranch cs
  csLR = countLoop rightBranch csL

Amazingly improved by BlackMeph


main = print . renameTreeNodes $ testTree

renameTreeNodes :: Tree a -> Tree Int
renameTreeNodes tree = t' where
    (t',ks) = renameLoop tree (1:ks)
    renameLoop EmptyLeaf cs = (EmptyLeaf,cs)
    renameLoop (Leaf _) (c:cs) = (Leaf c,(c+1):cs)
    renameLoop (Tree _ lb rb) (c:cs) = (Tree c lb' rb',(c+1):csLR) where
       (lb',csL)  = renameLoop lb cs
       (rb',csLR) = renameLoop rb csL

Source at HPASTE

Fascinating excursion in monads history

2008-05-27T04:21:00.000-07:00

The notion of monad comes from category theory. It first arose in the area of homological algebra, but later was recognised (due to the work of Kleisli and of Eilenberg and Moore) to have much wider applications.

Its importance emerged slowly: in early days, it was not even given a proper name, but called simply a "standard construction" or a "triple". The formulation used here is due to Kleisli.

Eugenio Moggi proposed that monads provide a useful structuring tool for denotational semantics. He showed how lambda calculus could be given call-by-value and call-by-name semantics in an arbitrary monad, and how monads could encapsulate
a wide variety of programming language features such as state, exception handling, and continuations.

Independent of Moggi, but at about the same time, Michael Spivey proposed that monads provide a useful structuring tool for exception handling in pure functional languages, and demonstrated this thesis with an elegant program for term rewriting. He showed how monads could treat exceptions and non-deterministic choice in a common framework, thus capturing precisely a notion that I had groped towards years earlier.

Inspired byMoggi and Spivey, I proposed monads as a general technique for structuring functional programs. My early proposals were based on a special syntax for monads, that generalised list comprehensions. This was unfortunate, in that it led many to think a special syntax was needed.

This new presentation is designed to convey that monads can be profitably applied to structure programs today with existing languages.

A key observation of Moggi's was that values and computations should be assigned different types: the value type a is distinct from the computation type M a. In a call-by-value language, functions take values into computations (as in a -> M b); in a call-by-name language, functions take computations into computations (as in M a -> M b).

John Reynolds made exactly the same point a decade ago. The essence of Algol, according to Reynolds, is a programming language that distinguishes data types from phrase types. In his work data types (such as int) play the roles of values, and phrase types (such as int exp) play the role of computations, and the same distinction between call-by-value and call-by-name appears. These ideas form the basis for the design of Forsythe. But the vital unitM and bindM operations do not appear in Reynolds' work.

This is not the only time that John Reynolds has been a decade ahead of the rest of us. Among other things, he was an early promoter of continuation-passing style and the first to apply category theory to language design. One intriguing aspect of his recent work is the use of intersection types, so perhaps we should expect an upsurge of interest in that topic early in the next millenium.

-- "The essence of functional programming", Philip Wadler, University of Glasgow.