From 479871f0191fe6871e047eb0049237016465ffa4 Mon Sep 17 00:00:00 2001 From: Duncan McGreggor Date: Fri, 21 Jun 2013 14:23:31 -0700 Subject: [PATCH] Added support for LFE (Lisp Flavored Erlang). --- lib/linguist/languages.yml | 7 ++ samples/LFE/church.lfe | 111 +++++++++++++++++++++++ samples/LFE/gps1.lfe | 104 ++++++++++++++++++++++ samples/LFE/mnesia_demo.lfe | 83 ++++++++++++++++++ samples/LFE/object.lfe | 169 ++++++++++++++++++++++++++++++++++++ 5 files changed, 474 insertions(+) create mode 100644 samples/LFE/church.lfe create mode 100644 samples/LFE/gps1.lfe create mode 100644 samples/LFE/mnesia_demo.lfe create mode 100644 samples/LFE/object.lfe diff --git a/lib/linguist/languages.yml b/lib/linguist/languages.yml index 5526dd85..a016897c 100644 --- a/lib/linguist/languages.yml +++ b/lib/linguist/languages.yml @@ -680,6 +680,13 @@ Kotlin: - .ktm - .kts +LFE: + type: programming + primary_extension: .lfe + color: "#004200" + Lexer: Common Lisp + group: Erlang + LLVM: primary_extension: .ll diff --git a/samples/LFE/church.lfe b/samples/LFE/church.lfe new file mode 100644 index 00000000..b99d44ba --- /dev/null +++ b/samples/LFE/church.lfe @@ -0,0 +1,111 @@ +;; Copyright (c) 2013 Duncan McGreggor +;; +;; Licensed under the Apache License, Version 2.0 (the "License"); +;; you may not use this file except in compliance with the License. +;; You may obtain a copy of the License at +;; +;; http://www.apache.org/licenses/LICENSE-2.0 +;; +;; Unless required by applicable law or agreed to in writing, software +;; distributed under the License is distributed on an "AS IS" BASIS, +;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;; See the License for the specific language governing permissions and +;; limitations under the License. + +;; File : church.lfe +;; Author : Duncan McGreggor +;; Purpose : Demonstrating church numerals from the lambda calculus + +;; The code below was used to create the section of the user guide here: +;; http://lfe.github.io/user-guide/recursion/5.html +;; +;; Here is some example usage: +;; +;; > (slurp '"church.lfe") +;; #(ok church) +;; > (zero) +;; #Fun +;; > (church->int1 (zero)) +;; 0 +;; > (church->int1 (three)) +;; 3 +;; > (church->int1 (five)) +;; 5 +;; > (church->int2 #'five/0) +;; 5 +;; > (church->int2 (lambda () (get-church 25))) +;; 25 + +(defmodule church + (export all)) + +(defun zero () + (lambda (s) + (lambda (x) x))) + +(defun one () + (lambda (s) + (lambda (x) + (funcall s x)))) + +(defun two () + (lambda (s) + (lambda (x) + (funcall s + (funcall s x))))) + +(defun three () + (lambda (s) + (lambda (x) + (funcall s + (funcall s + (funcall s x)))))) + +(defun four () + (lambda (s) + (lambda (x) + (funcall s + (funcall s + (funcall s + (funcall s x))))))) + +(defun five () + (get-church 5)) + +(defun int-successor (n) + (+ n 1)) + +(defun church->int1 (church-numeral) + " + Converts a called church numeral to an integer, e.g.: + > (church->int1 (five)) + " + (funcall + (funcall church-numeral #'int-successor/1) 0)) + +(defun church->int2 (church-numeral) + " + Converts a non-called church numeral to an integer, e.g.: + > (church->int2 #'five/0) + " + (funcall + (funcall + (funcall church-numeral) #'int-successor/1) 0)) + +(defun church-successor (church-numeral) + (lambda (s) + (lambda (x) + (funcall s + (funcall + (funcall church-numeral s) x))))) + +(defun get-church (church-numeral count limit) + (cond ((== count limit) church-numeral) + ((/= count limit) + (get-church + (church-successor church-numeral) + (+ 1 count) + limit)))) + +(defun get-church (integer) + (get-church (zero) 0 integer)) diff --git a/samples/LFE/gps1.lfe b/samples/LFE/gps1.lfe new file mode 100644 index 00000000..41115572 --- /dev/null +++ b/samples/LFE/gps1.lfe @@ -0,0 +1,104 @@ +;;; -*- Mode: LFE; -*- +;;; Code from Paradigms of Artificial Intelligence Programming +;;; Copyright (c) 1991 Peter Norvig + +;;;; File gps1.lisp: First version of GPS (General Problem Solver) + +;;;; Converted to LFE by Robert Virding + +;; Define macros for global variable access. This is a hack and very naughty! +(defsyntax defvar + ([name val] (let ((v val)) (put 'name v) v))) + +(defsyntax setvar + ([name val] (let ((v val)) (put 'name v) v))) + +(defsyntax getvar + ([name] (get 'name))) + +;; Module definition. + +(defmodule gps1 + (export (gps 2) (gps 3) (school-ops 0)) + (import (from lists (member 2) (all 2) (any 2)) + ;; Rename lists functions to be more CL like. + (rename lists ((all 2) every) ((any 2) some) ((filter 2) find-all)))) + +;; An operation. +(defrecord op + action preconds add-list del-list) + +;; General Problem Solver: achieve all goals using *ops*. +(defun gps (state goals ops) + ;; Set global variables + (defvar *state* state) ;The current state: a list of conditions. + (defvar *ops* ops) ;A list of available operators. + (if (every (fun achieve 1) goals) 'solved)) + +(defun gps (state goals) + ;; Set global variables, but use existing *ops* + (defvar *state* state) ;The current state: a list of conditions. + (if (every (fun achieve 1) goals) 'solved)) + +;; A goal is achieved if it already holds or if there is an +;; appropriate op for it that is applicable." +(defun achieve (goal) + (orelse (member goal (getvar *state*)) + (some (fun apply-op 1) + (find-all (lambda (op) (appropriate-p goal op)) + (getvar *ops*))))) + +;; An op is appropriate to a goal if it is in its add list. +(defun appropriate-p (goal op) + (member goal (op-add-list op))) + +;; Print a message and update *state* if op is applicable. +(defun apply-op (op) + (if (every (fun achieve 1) (op-preconds op)) + (progn + (: io fwrite '"executing ~p\n" (list (op-action op))) + (setvar *state* (set-difference (getvar *state*) (op-del-list op))) + (setvar *state* (union (getvar *state*) (op-add-list op))) + 'true))) + +;; Define the set functions to work on list, a listsets module really. +(defun set-difference + ([(cons e es) s2] + (if (member e s2) + (set-difference es s2) + (cons e (set-difference es s2)))) + ([() s2] ())) + +(defun union + ([(cons e es) s2] + (if (member e s2) (union es s2) (cons e (union es s2)))) + ([() s2] ())) + +;;; ============================== + +(defun school-ops () + (list + (make-op action 'drive-son-to-school + preconds '(son-at-home car-works) + add-list '(son-at-school) + del-list '(son-at-home)) + (make-op action 'shop-installs-battery + preconds '(car-needs-battery shop-knows-problem shop-has-money) + add-list '(car-works) + del-list ()) + (make-op action 'tell-shop-problem + preconds '(in-communication-with-shop) + add-list '(shop-knows-problem) + del-list ()) + (make-op action 'telephone-shop + preconds '(know-phone-number) + add-list '(in-communication-with-shop) + del-list ()) + (make-op action 'look-up-number + preconds '(have-phone-book) + add-list '(know-phone-number) + del-list ()) + (make-op action 'give-shop-money + preconds '(have-money) + add-list '(shop-has-money) + del-list '(have-money)))) diff --git a/samples/LFE/mnesia_demo.lfe b/samples/LFE/mnesia_demo.lfe new file mode 100644 index 00000000..f27014b6 --- /dev/null +++ b/samples/LFE/mnesia_demo.lfe @@ -0,0 +1,83 @@ +;; Copyright (c) 2008-2013 Robert Virding +;; +;; Licensed under the Apache License, Version 2.0 (the "License"); +;; you may not use this file except in compliance with the License. +;; You may obtain a copy of the License at +;; +;; http://www.apache.org/licenses/LICENSE-2.0 +;; +;; Unless required by applicable law or agreed to in writing, software +;; distributed under the License is distributed on an "AS IS" BASIS, +;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;; See the License for the specific language governing permissions and +;; limitations under the License. + +;; File : mnesia_demo.lfe +;; Author : Robert Virding +;; Purpose : A simple Mnesia demo file for LFE. + +;; This file contains a simple demo of using LFE to access Mnesia +;; tables. It shows how to use the emp-XXXX macro (ETS match pattern) +;; together with mnesia:match_object, match specifications with +;; mnesia:select and Query List Comprehensions. + +(defmodule mnesia_demo + (export (new 0) (by_place 1) (by_place_ms 1) (by_place_qlc 1))) + +(defrecord person name place job) + +(defun new () + ;; Start mnesia and create a table, we will get an in memory only schema. + (: mnesia start) + (: mnesia create_table 'person '(#(attributes (name place job)))) + ;; Initialise the table. + (let ((people '( + ;; First some people in London. + #(fred london waiter) + #(bert london waiter) + #(john london painter) + #(paul london driver) + ;; Now some in Paris. + #(jean paris waiter) + #(gerard paris driver) + #(claude paris painter) + #(yves paris waiter) + ;; And some in Rome. + #(roberto rome waiter) + #(guiseppe rome driver) + #(paulo rome painter) + ;; And some in Berlin. + #(fritz berlin painter) + #(kurt berlin driver) + #(hans berlin waiter) + #(franz berlin waiter) + ))) + (: lists foreach (match-lambda + ([(tuple n p j)] + (: mnesia transaction + (lambda () + (let ((new (make-person name n place p job j))) + (: mnesia write new)))))) + people))) + +;; Match records by place using match_object and the emp-XXXX macro. +(defun by_place (place) + (: mnesia transaction + (lambda () (: mnesia match_object (emp-person place place))))) + +;; Use match specifications to match records +(defun by_place_ms (place) + (let ((f (lambda () (: mnesia select 'person + (match-spec ([(match-person name n place p job j)] + (when (=:= p place)) + (tuple n j))))))) + (: mnesia transaction f))) + +;; Use Query List Comprehensions to match records +(defun by_place_qlc (place) + (let ((f (lambda () + (let ((q (qlc (lc ((<- person (: mnesia table 'person)) + (=:= (person-place person) place)) + person)))) + (: qlc e q))))) + (: mnesia transaction f))) diff --git a/samples/LFE/object.lfe b/samples/LFE/object.lfe new file mode 100644 index 00000000..f652bc1f --- /dev/null +++ b/samples/LFE/object.lfe @@ -0,0 +1,169 @@ +;; Copyright (c) 2013 Duncan McGreggor +;; +;; Licensed under the Apache License, Version 2.0 (the "License"); +;; you may not use this file except in compliance with the License. +;; You may obtain a copy of the License at +;; +;; http://www.apache.org/licenses/LICENSE-2.0 +;; +;; Unless required by applicable law or agreed to in writing, software +;; distributed under the License is distributed on an "AS IS" BASIS, +;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +;; See the License for the specific language governing permissions and +;; limitations under the License. + +;; File : object.lfe +;; Author : Duncan McGreggor +;; Purpose : Demonstrating simple OOP with closures + +;; The simple object system demonstrated below shows how to do the following: +;; * create objects +;; * call methods on those objects +;; * have methods which can call other methods +;; * update the state of an instance variable +;; +;; Note, however, that his example does not demonstrate inheritance. +;; +;; To use the code below in LFE, do the following: +;; +;; $ cd examples +;; $ ../bin/lfe -pa ../ebin +;; +;; Load the file and create a fish-class instance: +;; +;; > (slurp '"object.lfe") +;; #(ok object) +;; > (set mommy-fish (fish-class '"Carp")) +;; #Fun +;; +;; Execute some of the basic methods: +;; +;; > (get-species mommy-fish) +;; "Carp" +;; > (move mommy-fish 17) +;; The Carp swam 17 feet! +;; ok +;; > (get-id mommy-fish) +;; "47eebe91a648f042fc3fb278df663de5" +;; +;; Now let's look at "modifying" state data (e.g., children counts): +;; +;; > (get-children mommy-fish) +;; () +;; > (get-children-count mommy-fish) +;; 0 +;; > (set (mommy-fish baby-fish-1) (reproduce mommy-fish)) +;; (#Fun #Fun) +;; > (get-id mommy-fish) +;; "47eebe91a648f042fc3fb278df663de5" +;; > (get-id baby-fish-1) +;; "fdcf35983bb496650e558a82e34c9935" +;; > (get-children-count mommy-fish) +;; 1 +;; > (set (mommy-fish baby-fish-2) (reproduce mommy-fish)) +;; (#Fun #Fun) +;; > (get-id mommy-fish) +;; "47eebe91a648f042fc3fb278df663de5" +;; > (get-id baby-fish-2) +;; "3e64e5c20fb742dd88dac1032749c2fd" +;; > (get-children-count mommy-fish) +;; 2 +;; > (get-info mommy-fish) +;; id: "47eebe91a648f042fc3fb278df663de5" +;; species: "Carp" +;; children: ["fdcf35983bb496650e558a82e34c9935", +;; "3e64e5c20fb742dd88dac1032749c2fd"] +;; ok + +(defmodule object + (export all)) + +(defun fish-class (species) + " + This is the constructor that will be used most often, only requiring that + one pass a 'species' string. + + When the children are not defined, simply use an empty list. + " + (fish-class species ())) + +(defun fish-class (species children) + " + This contructor is mostly useful as a way of abstracting out the id + generation from the larger constructor. Nothing else uses fish-class/2 + besides fish-class/1, so it's not strictly necessary. + + When the id isn't know, generate one." + (let* (((binary (id (size 128))) (: crypto rand_bytes 16)) + (formatted-id (car + (: io_lib format + '"~32.16.0b" (list id))))) + (fish-class species children formatted-id))) + +(defun fish-class (species children id) + " + This is the constructor used internally, once the children and fish id are + known. + " + (let ((move-verb '"swam")) + (lambda (method-name) + (case method-name + ('id + (lambda (self) id)) + ('species + (lambda (self) species)) + ('children + (lambda (self) children)) + ('info + (lambda (self) + (: io format + '"id: ~p~nspecies: ~p~nchildren: ~p~n" + (list (get-id self) + (get-species self) + (get-children self))))) + ('move + (lambda (self distance) + (: io format + '"The ~s ~s ~p feet!~n" + (list species move-verb distance)))) + ('reproduce + (lambda (self) + (let* ((child (fish-class species)) + (child-id (get-id child)) + (children-ids (: lists append + (list children (list child-id)))) + (parent-id (get-id self)) + (parent (fish-class species children-ids parent-id))) + (list parent child)))) + ('children-count + (lambda (self) + (: erlang length children))))))) + +(defun get-method (object method-name) + " + This is a generic function, used to call into the given object (class + instance). + " + (funcall object method-name)) + +; define object methods +(defun get-id (object) + (funcall (get-method object 'id) object)) + +(defun get-species (object) + (funcall (get-method object 'species) object)) + +(defun get-info (object) + (funcall (get-method object 'info) object)) + +(defun move (object distance) + (funcall (get-method object 'move) object distance)) + +(defun reproduce (object) + (funcall (get-method object 'reproduce) object)) + +(defun get-children (object) + (funcall (get-method object 'children) object)) + +(defun get-children-count (object) + (funcall (get-method object 'children-count) object)) \ No newline at end of file