job:  #8612  model compare test had incorrect indenting on Override.

.function generate_class_header
//========================================================================
//
// File: <complete_generated_file_path>.java
//
// WARNING:      Do not edit this generated file
// Generated by: ${info.arch_file_name}
// Version:      $$Revision: 1.7.8.2 $$
//
// Copyright 2005-2014 Mentor Graphics Corporation.  All rights reserved.
//
//========================================================================
// 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.
//========================================================================
package org.xtuml.bp.model.compare.test;

import java.io.IOException;
import java.lang.reflect.InvocationTargetException;
import java.lang.reflect.Method;
import java.util.Iterator;
import java.util.Set;
import org.junit.After;
import org.junit.Before;
import org.junit.Test;
import org.junit.runner.RunWith;
import org.eclipse.compare.internal.CompareEditor;
import org.eclipse.core.resources.IFile;
import org.eclipse.core.resources.IProject;
import org.eclipse.core.resources.ResourcesPlugin;
import org.eclipse.core.runtime.CoreException;
import org.eclipse.core.runtime.NullProgressMonitor;
import org.eclipse.core.runtime.Path;
import org.eclipse.jface.viewers.StructuredSelection;
import org.eclipse.team.internal.ui.actions.CompareAction;
import org.eclipse.ui.IEditorPart;
import org.eclipse.ui.PlatformUI;

import org.xtuml.bp.core.*;
import org.xtuml.bp.core.common.ClassQueryInterface_c;
import org.xtuml.bp.core.common.ModelRoot;
import org.xtuml.bp.core.common.NonRootModelElement;
import org.xtuml.bp.core.common.PersistableModelComponent;
import org.xtuml.bp.test.common.OrderedRunner;
import org.xtuml.bp.core.common.Transaction;
import org.xtuml.bp.core.common.TransactionException;
import org.xtuml.bp.core.common.TransactionManager;
import org.xtuml.bp.core.inspector.ObjectElement;
import org.xtuml.bp.core.util.WorkspaceUtil;
import org.xtuml.bp.model.compare.ComparableTreeObject;
import org.xtuml.bp.model.compare.TreeDifference;
import org.xtuml.bp.model.compare.TreeDifferencer;
import org.xtuml.bp.model.compare.providers.NonRootModelElementComparable;
import org.xtuml.bp.test.common.BaseTest;
import org.xtuml.bp.ui.canvas.Fillcolorstyle_c;
import org.xtuml.bp.ui.canvas.FloatingText_c;
import org.xtuml.bp.ui.canvas.Graphconnector_c;
import org.xtuml.bp.ui.canvas.Graphelement_c;
import org.xtuml.bp.ui.canvas.Graphnode_c;
import org.xtuml.bp.ui.canvas.Layer_c;
import org.xtuml.bp.ui.canvas.Linecolorstyle_c;
import org.xtuml.bp.ui.canvas.Model_c;
import org.xtuml.bp.ui.canvas.Ooaofgraphics;
import org.xtuml.bp.ui.canvas.Waypoint_c;

@RunWith(OrderedRunner.class)
public class ModelComparisonTests extends BaseTest {

	private static String modifyString = "_modified";

	@Override
	public void initialSetup() throws CoreException, IOException {
		// load test model
		WorkspaceUtil.setAutobuilding(false);

		final IProject project = ResourcesPlugin.getWorkspace().getRoot()
				..getProject("HierarchyTestModel");

		loadProject("HierarchyTestModel");

		m_sys = SystemModel_c.SystemModelInstance(Ooaofooa
				..getDefaultInstance(), new ClassQueryInterface_c() {

			public boolean evaluate(Object candidate) {
				return ((SystemModel_c) candidate).getName().equals(
						project.getName());
			}

		});
		PersistableModelComponent sys_comp = m_sys
				..getPersistableComponent();
		sys_comp.loadComponentAndChildren(new NullProgressMonitor());
	}

.end function
.function generate_helper_methods
	@SuppressWarnings("restriction")
	private TreeDifferencer compareElementWithLocalHistory(NonRootModelElement instance, IFile copy) {
		IFile file = instance.getFile();
		CompareAction action = new CompareAction();
		action.selectionChanged(null, new StructuredSelection(new Object[] {
				file, copy }));
		action.run(null);
		IEditorPart activeEditor = PlatformUI.getWorkbench()
				..getActiveWorkbenchWindow().getActivePage().getActiveEditor();
		assertTrue("Unable to locate compare editor.", activeEditor instanceof CompareEditor);
		while(PlatformUI.getWorkbench().getDisplay().readAndDispatch());
		Set<Object> keySet = TreeDifferencer.instances.keySet();
		Object key = null;
		for(Iterator<Object> iterator = keySet.iterator(); iterator.hasNext();) {
			key = iterator.next();
		}
		return TreeDifferencer.instances.get(key);
	}

	private void performTest(NonRootModelElement instance, String methodName,
			String modelPath, Object newValue) throws SecurityException,
			NoSuchMethodException, CoreException, IllegalArgumentException,
			IllegalAccessException, InvocationTargetException {
		IFile copy = null;
		Transaction transaction = null;
		try {
			instance.getFile().copy(
					new Path("/" + instance.getFile().getProject().getName() + "/"
							+ instance.getFile().getName()), true,
					new NullProgressMonitor());
			copy = instance.getFile().getProject().getFile(
					instance.getFile().getName());
			TransactionManager manager = TransactionManager.getSingleton();
				transaction = manager.startTransaction(
						"Modify attribute value for " + modelPath, new ModelRoot[] {
								Ooaofooa.getDefaultInstance(),
								Ooaofgraphics.getDefaultInstance() });
				Method[] methods = instance.getClass().getMethods();
				for(Method method : methods) {
					if(method.getName().equals(methodName)) {
						method.invoke(instance, new Object[] { newValue });
						break;
					}
				}
				manager.endTransaction(transaction);
			TreeDifferencer differencer = compareElementWithLocalHistory(instance,
					copy);
			assertTrue("No differences found for attribute value modification: "
					+ modelPath, differencer.getLeftDifferences().size() != 0);
			assertTrue(
					"More differences found for attribute value modification than expected.",
					differencer.getLeftDifferences().size() == getExpectedSizeForChange(differencer, instance));
			if(getExpectedSizeForChange(differencer, instance) == 1) {
				assertTrue(
						"Invalid difference type found for attribute value modification.",
						differencer.getLeftDifferences().get(0).getType() == TreeDifference.VALUE_DIFFERENCE);
			}
		} catch(Exception e) {
			if(transaction != null) {
				TransactionManager.getSingleton().cancelTransaction(transaction);
			}
			fail("Unable to modify attribute value.");
		} finally {
			// undo the change
			if(transaction != null) {
				TransactionManager.getSingleton().getUndoAction().run();
			}
			// remove copy
			if(copy != null) {
				copy.delete(true, new NullProgressMonitor());
			}
			PlatformUI.getWorkbench().getActiveWorkbenchWindow().getActivePage().closeAllEditors(false);
			while(PlatformUI.getWorkbench().getDisplay().readAndDispatch());
		}
	}

	private int getExpectedSizeForChange(TreeDifferencer differencer, Object testElement) {
		if(getName().contains("Layer_Name")) {
			return 2;
		}
		if(differencer.getLeftDifferences().size() == 2) {
			// this could be rename, where the differences
			// are shown both for the attribute and the root
			// element
			for(TreeDifference difference : differencer.getLeftDifferences()) {
				if(difference.getType().equals(TreeDifference.VALUE_DIFFERENCE)) {
					ComparableTreeObject comparable = (ComparableTreeObject) difference.getElement();
					if(comparable.getRealElement() instanceof ObjectElement) {
						ObjectElement obEle = (ObjectElement) comparable.getRealElement();
						ComparableTreeObject one = new NonRootModelElementComparable((NonRootModelElement) testElement);
						ComparableTreeObject two = new NonRootModelElementComparable((NonRootModelElement) obEle.getParent());
						if(one.equals(two)) {
							return 2;
						} else {
							return 1;
						}
					} else {
						return 1;
					}
				}
				if(difference.getType().equals(TreeDifference.NAME_DIFFERENCE)) {
					continue;
				} else {
					return 1;
				}
			}
		} else if(differencer.getLeftDifferences().size() == 3) {
			int count = 0;
			for(TreeDifference difference : differencer.getLeftDifferences()) {
				if(difference.getType().equals(TreeDifference.VALUE_DIFFERENCE)) {
					ComparableTreeObject comparable = (ComparableTreeObject) difference.getElement();
					if(comparable.getRealElement() instanceof ObjectElement) {
						ObjectElement obEle = (ObjectElement) comparable.getRealElement();
						ComparableTreeObject one = new NonRootModelElementComparable((NonRootModelElement) testElement);
						ComparableTreeObject two = new NonRootModelElementComparable((NonRootModelElement) obEle.getParent());
						if(one.equals(two)) {
							if(count == 1) {
								count++;
								continue;
							} else if(count == 2) {
								return 3;
							}
						} else {
							return 1;
						}
					} else {
						return 1;
					}
				}
				if(difference.getType().equals(TreeDifference.NAME_DIFFERENCE)) {
					count++;
					continue;
				} else {
					return 1;
				}
			}
		}
		return 1;
	}
.end function
.function get_set_value
  .param inst_ref attribute
    .select one dt related by attribute->S_DT[R114]
    .assign attr_result = ""
    .if(dt.Name == "boolean")
      .assign attr_result = "!instance.get$cr{attribute.Name}()"
    .elif(dt.Name == "string")
      .assign attr_result = "instance.get$cr{attribute.Name}() + modifyString"
    .elif(dt.Name == "integer")
      .assign attr_result = "instance.get$cr{attribute.Name}() + 1"
    .elif(dt.Name == "real")
	  .assign attr_result = "instance.get$cr{attribute.Name}() + 1"
	.elif(dt.Name == "unique_id")
	  .assign attr_result = "UUID.randomUUID()"
	.elif(dt.Name == "ParseStatus")
	  .assign attr_result = "Parsestatus_c.doNotParse"
	.elif(dt.Name == "Scope")
	  .assign attr_result = "Scope_c.Class"
	.elif(dt.Name == "Visibility")
	  .assign attr_result = "Visibility_c.Protected"
	.elif(dt.Name == "IFDirectionType")
	  .assign attr_result = "Ifdirectiontype_c.ServerClient"
	.elif(dt.Name == "ElementTypeConstants")
	  .assign attr_result = "Elementtypeconstants_c.DELEGATION"
	.elif(dt.Name == "instance")
	  .assign attr_result = "m_sys"
	.elif(dt.Name == "End")
	  .assign attr_result = "End_c.None"
    .end if
.end function
.function isGraphicalCheck
  .param inst_ref class
    .assign attr_isGraphical = false
    .select one parentPkg related by class->PE_PE[R8001]->EP_PKG[R8000]
    .select one grandParentPkg related by parentPkg->PE_PE[R8001]->EP_PKG[R8000]
    .if(not_empty grandParentPkg)
      .if(grandParentPkg.Name == "ooaofgraphics")
        .assign attr_isGraphical = true
      .end if
    .end if
.end function
.function generate_simple_attribute_value_tests
  .param inst_ref attr
    .select one class related by attr->O_OBJ[R102]
    /**
     *  Test modification of attribute: ${class.Name}:${attr.Name}
     */
	@Test
	public void testAttributeValueModification$_{class.Name}$_{attr.Name}() throws CoreException, SecurityException, IllegalArgumentException,
			NoSuchMethodException, IllegalAccessException,
			InvocationTargetException {
		$Cr{class.Name}_c instance = null;
   .invoke igc = isGraphicalCheck(class)
   .if(igc.isGraphical)
		Ooaofgraphics[] roots = Ooaofgraphics.getInstances();
		for(Ooaofgraphics root : roots) {
			instance = $Cr{class.Name}_c.$Cr{class.Name}Instance(root);
			if(instance != null && instance.getFile() != null) {
				break;
			}
		}
   .else
		Ooaofooa[] roots = Ooaofooa.getInstancesUnderSystem("HierarchyTestModel");
		for(Ooaofooa root : roots) {
			instance = $Cr{class.Name}_c.$Cr{class.Name}Instance(root);
     .if(attr.Name == "Visibility")
     		instance = null;
     		ModelClass_c modelClass = ModelClass_c.ModelClassInstance(root);
     		if(modelClass != null) {
				instance = PackageableElement_c.getOnePE_PEOnR8001(modelClass);
			}
	 .end if
	 .if(class.Name == "State Machine Event")
			SignalEvent_c sig = SignalEvent_c.getOneSM_SGEVTOnR526(SemEvent_c.getOneSM_SEVTOnR525(instance));
			if(instance != null && instance.getFile() != null && sig == null) {
			    break;
			}
	 .elif(class.Name == "Data Type")
			InstanceReferenceDataType_c irdt = InstanceReferenceDataType_c.getOneS_IRDTOnR17(instance);
			if(irdt != null) {
				instance = null;
				continue;
			}
     		if(instance != null && instance.getFile() != null) {
				break;
			}
     .else
     		if(instance != null && instance.getFile() != null) {
				break;
			}
	 .end if
		}
   .end if
		assertNotNull("Unable to locate test element for: ${class.Name}::${attr.Name}", instance);
    .invoke gsv = get_set_value(attr)
    .if(attr.Name == "Action_Semantics")
        performTest(instance, "setAction_semantics_internal", "${class.Name}::Action_Semantics_internal", instance.getAction_semantics_internal() + "_modified");
    .else
		performTest(instance, "set$cr{attr.Name}", "${class.Name}::${attr.Name}", ${gsv.result});
    .end if
	}
.end function
.function is_excluded
  .param inst_ref class
    .assign attr_result = false;
    .select one pkg related by class->PE_PE[R8001]->EP_PKG[R8000]
    .if(pkg.Name == "Body")
      .assign attr_result = true
    .elif(pkg.Name == "Breakpoint")
      .assign attr_result = true
    .elif(pkg.Name == "Communication and Access")
      .assign attr_result = true
    .elif(pkg.Name == "Event")
      .assign attr_result = true
    .elif(pkg.Name == "Globals")
      .assign attr_result = true
    .elif(pkg.Name == "Engine")
      .assign attr_result = true
    .elif(pkg.Name == "Local")
      .assign attr_result = true
    .elif(pkg.Name == "")
      .assign attr_result = true
    .elif(pkg.Name == "Runtime Value")
      .assign attr_result = true
    .elif(pkg.Name == "Search")
      .assign attr_result = true
    .elif(pkg.Name == "Value")
      .assign attr_result = true
    .elif(pkg.Name == "Wiring")
      .assign attr_result = true
    .elif(pkg.Name == "Participation")
      .assign attr_result = true
    .elif(pkg.Name == "Result")
      .assign attr_result = true
    .elif(pkg.Name == "Query")
      .assign attr_result = true
    .elif(pkg.Name == "Engine")
      .assign attr_result = true
    .elif(pkg.Name == "Terminal Specifications")
      .assign attr_result = true
    .elif(pkg.Name == "CT")
      .assign attr_result = true
    .elif(class.Key_Lett == "S_DOM")
      .assign attr_result = true
    .elif(class.Key_Lett == "CP_CP")
      .assign attr_result = true
    .elif(class.Key_Lett == "A_A")
      .assign attr_result = true
    .elif(class.Key_Lett == "A_AIA")
      .assign attr_result = true
    .elif(class.Key_Lett == "COMM_COMM")
      .assign attr_result = true
    .elif(class.Key_Lett == "COMM_CIC")
      .assign attr_result = true
    .elif(class.Key_Lett == "CP_CPINP")
      .assign attr_result = true
    .elif(class.Key_Lett == "S_DPK")
      .assign attr_result = true
    .elif(class.Key_Lett == "S_DPIP")
      .assign attr_result = true
    .elif(class.Key_Lett == "S_EEPIP")
      .assign attr_result = true
    .elif(class.Key_Lett == "S_EEPK")
      .assign attr_result = true
    .elif(class.Key_Lett == "S_EEIP")
      .assign attr_result = true
    .elif(class.Key_Lett == "S_FPK")
      .assign attr_result = true
    .elif(class.Key_Lett == "S_FIP")
      .assign attr_result = true
    .elif(class.Key_Lett == "S_FPIP")
      .assign attr_result = true
    .elif(class.Key_Lett == "S_SS")
      .assign attr_result = true
    .elif(class.Key_Lett == "S_SID")
      .assign attr_result = true
    .elif(class.Key_Lett == "S_SIS")
      .assign attr_result = true
    .elif(class.Key_Lett == "EP_PIP")
      .assign attr_result = true
    .elif(class.Key_Lett == "EP_SPKG")
      .assign attr_result = true
    .elif(class.Key_Lett == "IP_IP")
      .assign attr_result = true
    .elif(class.Key_Lett == "IP_IPINIP")
      .assign attr_result = true
    .elif(class.Key_Lett == "PA_DIC")
      .assign attr_result = true
    .elif(class.Key_Lett == "PA_SIC")
      .assign attr_result = true
    .elif(class.Key_Lett == "PA_SICP")
      .assign attr_result = true
    .elif(class.Key_Lett == "SQ_S")
      .assign attr_result = true
    .elif(class.Key_Lett == "SQ_MIS")
      .assign attr_result = true
    .elif(class.Key_Lett == "SQ_SIS")
      .assign attr_result = true
    .elif(pkg.Name == "System Level Datatypes")
      .assign attr_result = true
    .elif(class.Key_Lett == "UC_PIUC")
      .assign attr_result = true
    .elif(class.Key_Lett == "UC_UCC")
      .assign attr_result = true
    .elif(class.Key_Lett == "UC_UIU")
      .assign attr_result = true
    .elif(class.Key_Lett == "S_EEDI")
      .assign attr_result = true
    .elif(class.Key_Lett == "S_EEEVT")
      .assign attr_result = true
    .elif(class.Key_Lett == "S_EEEDT")
      .assign attr_result = true
    .elif(class.Key_Lett == "S_EEEDI")
      .assign attr_result = true
    .elif(class.Key_Lett == "S_EEM")
      .assign attr_result = true
    .elif(class.Key_Lett == "R_CONE")
      .assign attr_result = true
    .elif(class.Key_Lett == "R_COTH")
      .assign attr_result = true
    .elif(class.Key_Lett == "SQ_FPP")
      .assign attr_result = true
	.elif(class.Key_Lett == "R_COMP")
	  .assign attr_result = true
	.elif(class.Key_Lett == "STY_FS")
	  .assign attr_result = true
	.elif(class.Key_Lett == "DIM_DIA")
	  .assign attr_result = true
    .end if
    .assign exclude = "$l{class.Descrip:PEI}" == "true"
    .if(exclude)
      .assign attr_result = true
    .end if
    .assign exclude = "$l{class.Descrip:Persistent}" == "false"
    .if(exclude)
      .assign attr_result = true
    .end if
    .assign exclude = "$l{class.Descrip:persistent}" == "false"
    .if(exclude)
      .assign attr_result = true
    .end if
.end function
.function non_mod_attribute
  .param Inst_Ref attribute
    .assign attr_non_mod = false
    .select one class related by attribute->O_OBJ[R102]
    .if((class.Name == "Package") and (attribute.Name == "Name"))
      .assign attr_non_mod = true
    .end if
    .if((class.Name == "Interface") and (attribute.Name == "Name"))
      .assign attr_non_mod = true
    .end if
    .if((class.Name == "Model Class") and (attribute.Name == "Name"))
      .assign attr_non_mod = true
    .end if
    .if((class.Name == "Component") and (attribute.Name == "Name"))
      .assign attr_non_mod = true
    .end if
.end function
.select many classes from instances of O_OBJ
.assign count = 0
.assign c = 0;
.assign test_count = 1;
.invoke gch = generate_class_header()
${gch.body}
.for each class in classes
  .invoke excluded = is_excluded(class);
  .assign exclude = excluded.result
  .if(not exclude)
    .// make sure this element is actually output
    .select any eo from instances of EO where (selected.Name == class.Name)
    .if(empty eo)
      .assign exclude = true;
    .end if
  .end if
  .if(not exclude)
    .select any ts from instances of T_TNS where (selected.Key_Lett == class.Key_Lett)
    .if(empty ts)
      .print "Did not find node for: ${class.Name} - ${class.Key_Lett}"
    .end if
    .select many attrs related by class->O_ATTR[R102];
    .for each attr in attrs
      .assign non_mod = "$l{attr.Descrip:User_Visible}" == "false"
      .if(not non_mod)
        .assign non_mod = "$l{attr.Descrip:readonly}" == "true"
      .end if
      .if(not non_mod)
        .assign non_mod = "$l{attr.Descrip:persistent}" == "false"
      .end if
      .if(not non_mod)
        .assign non_mod = "$l{attr.Descrip:Persistent}" == "false"
      .end if
      .invoke nma = non_mod_attribute(attr)
      .if(not non_mod)
        .assign non_mod = nma.non_mod
      .end if
      .select one rattr related by attr->O_RATTR[R106];
      .select one dbattr related by attr->O_BATTR[R106]->O_DBATTR[R107]
      .if(not_empty rattr)
      .elif((not_empty dbattr) and (attr.Name != "Action_Semantics"))
      .else
        .if(not non_mod)
          .select one dt related by attr->S_DT[R114]
          .if(dt.Name != "unique_id")
            .if((attr.Name != "represents") and ((class.Name != "DiagramElement") and (attr.Name != "isVisible")))
              .invoke gavt = generate_simple_attribute_value_tests(attr)
${gavt.body}
              .assign test_count = test_count + 1
            .end if
          .end if
        .end if
      .end if
    .end for
    .assign count = count + 1
  .end if
.end for
.invoke ghm = generate_helper_methods()
${ghm.body}
}
.emit to file "src/org/xtuml/bp/model/compare/test/ModelComparisonTests.java"
.print "Class count = ${count}"
.select many nodes from instances of T_TNS
.assign count = 0
.for each node in nodes
  .assign count = count + 1
.end for
.print "Tree node count = ${count}"
.print "Generated test count = ${test_count}"


add documentation to between change

add documentation to between change

; lib/util.arc: A collection of useful miscellanea

; Contributors:
; - Michael Arntzenius <daekharel@gmail.com>

; Persons we've shamelessly ripped off:
; - Conan Dalton <conan@conandalton.net>
; - absz (http://arclanguage.org/user?id=absz)
; - fallintothis (http://arclanguage.org/user?id=fallintothis)

; License: Do what you want, but it's not my fault!
; This license applies to all code in this file UNLESS OTHERWISE NOTED.

; Feel free to make additions to this file and push them to anarki. Keep it to
; stuff that is widely applicable. Don't remove or change the semantics of stuff
; other people added. Add yourself to the contributors list above if you want.

; If you wish to use a different license, make a comment around the code you've
; contributed noting the license. No licenses that don't permit modification
; (duh) and redistribution (double duh).

; Try and keep track of what is whose in sections with unknown licenses
; ("ripoffs").

; miscellaneous

(def fst (a . _) " Returns its first argument. See also [[snd]] " a)
(def snd (a b . _) " Returns its second argument. See also [[fst]] " b)

(def bool (x)
  " Returns `t' if x is not nil, and `nil' otherwise. "
  (if x t))

(def uniqs (lst)
  " Returns a list of gensyms, one for each element of `lst'. Elements
    of `lst' that are symbols are used as the base names for their
    corresponding gensyms.
    See also [[uniq]] "
  (map1 (iff asym uniq [uniq]) lst))

(def gc () ($.collect-garbage))

; type checkers
(def asym (x) " `t' iff `x' is a symbol. " (isa x 'sym))
(def astring (x) " `t' iff `x' is a string. " (isa x 'string))
(def atable (x) " `t' iff `x' is a table. " (isa x 'table))
(def aint (x) " `t' iff `x' is an int. " (isa x 'int))
(def anum (x) " `t' iff `x' is a num. Note that ints are not nums. "
  (isa x 'num))

; list manipulation

; 'reduce and 'rreduce have somewhat quirky behavior, well-suited to arithmetic
; functions, but otherwise hard to reason about. I usually prefer 'foldl and
; 'foldr.
(def foldl (f v l)
  (if l (foldl f (f v car.l) cdr.l) v))

(def foldr (f v l)
  (foldl flip.f v rev.l))

(def foot (l)
  " Gets the last cons in a proper list. (Fails on dotted lists.) "
  (aif cdr.l foot.it l))

(def join/d ls
  " Destructive join.
    See also [[join]]"
  (foldr (afn (a b) (if b (aif foot.a (do (scdr it b) a) b) a)) nil ls))

(def classify (classifier seq)
  " Groups the elements of `seq' by `classifier', returning back a table,
    whose keys are the results of `classifier' and whose values are lists
    of the corresponding elements of `seq'. For example:

      arc> (classify type '(1 \"foo\" a 2 (b)))
      #hash((cons . ((b))) (int . (2 1)) (string . (\"foo\")) (sym . (a)))

    See also [[partition]] [[keep]] [[rem]] "
  (w/table h
    (each e seq
      (push e (h classifier.e)))))

(def partition (test seq)
  " Equivalent to but more efficient than
   `(list (keep test seq) (rem test seq))'. See also [[keep]] [[rem]] "
  (let (passed failed) nil
    (each e seq
      (if test.e
        (push e passed)
        (push e failed)))
    (list rev.passed rev.failed)))

(def unzip (xs)
  " Precisely as `zip', except that zip's `ls' is unzip's `xs'; so it takes one
    list of lists rather than any number of lists as arguments. Can be thought
    of as performing the inverse operation.
    See also [[zip]] "
  (apply map list xs))

(def zip ls
  " Returns a list of lists; the n-th element of the result is a list of the
    n-th elements of the lists in `ls'. The length of the result is the length
    of the shortest list in `ls'; extra elements in other lists are discarded.
    See also [[unzip]] "
  (unzip ls))

(def mklist (x)
  " Wraps atoms in a list; does nothing if `x' is already a list.
    See also [[atom]] [[alist]] [[list]] "
  (check x alist list.x))

; 'many was precisely the same function as 'acons, hence has been removed (any
; cons has a length > 0, since nil is not a cons). Also, 'popfind has been
; renamed 'pull1, to fit with the newly-added 'rem1.

(def rem1 (test seq)
  " Returns a copy of `seq' with the first element that passes `test' removed.
    See also [[rem]] [[keep]] [[pull1]] [[pull]] "
  (zap testify test)
  (if alist.seq ((afn (s)
                   (if no.s nil
                       (f car.s) cdr.s
                       (cons car.s (self cdr.s))))
                 seq)
      (coerce (rem1 test (coerce seq 'cons)) 'string)))

(mac pull1 (test place)
  " Removes the first element that passes `test' from `place'.
    See also [[pull]] [[rem1]] [[rem]] [[keep]] "
  `(= ,place (rem1 ,test ,place)))

(def butlast (x)
  " Returns a list containing every element of `x' but the last.
    See also: [[cut]] "
  (cut x 0 (- (len x) 1)))

(= len= [is len._a _b])
(= len- [- len._a _b])
(= car< [< car._a car._b])
(= cdar cdr:car)
(= cadar car:cdar)
(= mapcar [map car _])
(= mapcdr [map cdr _])

(def keepkey (key lst) (keep [_ key] lst))
(def mapkey (key lst) (map [_ key] lst))

(def rand-pos (lst) (if lst (rand:len lst)))

(mac pushend (elem lst)
  `(= ,lst (join ,lst (list ,elem))))

(mac popnth (lst n)
  (w/uniq g1
    `(let ,g1 (,lst ,n)
       (= ,lst (+ (cut ,lst 0 ,n) (cut ,lst (+ 1 ,n))))
       ,g1)))

(mac poprand (lst)
  (w/uniq g1
    `(if ,lst
	 (let ,g1 (rand-pos ,lst)
	   (popnth ,lst ,g1)))))

; combinators

(def applied (f)
  " Returns a fn that calls `f' on the list of its arguments.
    For example, 'max is equivalent to `(applied [best > _])'. "
  (fn a (f a)))

(def flip (f)
  " Flips the order of the first two arguments of `f'.
    For example: ((flip cons) 1 2) => (2 . 1) "
  (fn (x y . zs) (apply f y x zs)))

(def curry (f . xs)
  " Partially applies (\"curries\") `f' to `xs'. "
  (fn ys (apply f (join xs ys))))

(def const (x)
  " Creates a fn that takes any number of arguments and returns `x'. "
  (fn _ x))

(def tfn _ " Ignores its arguments and returns t. " t)
(def nilfn _ " Ignores its arguments and returns nil. " nil)

(def norf fns
  " Creates a function which returns `t' iff none of `fns' return `t'
    on its arguments.
    See also [[orf]] [[andf]] [[nor]] "
  (complement (apply orf fns)))

(def iff funs
  " Put simply: iff is to if as andf is to and. Specifically:

    (iff) => idfn
    (iff fun) => fun
    (iff test fun rest ...) => a fn that applies `fun' to its arguments if they
    pass `test', otherwise applies `(iff rest...)' to them.

    Examples:

      arc> ((iff alist car) '(x))
      x
      arc> ((iff alist car) 2)
      2
      arc> ((iff < (fn (x y) x) (fn (x y) y)) 1 2)
      1

    See also [[andf]] [[orf]] [[check]] [[idfn]] "
  (case len.funs
    0 idfn
    1 funs.0
      (withs ((test fun . rest) funs
              restfun (apply iff rest))
        (fn a (if (apply test a) (apply fun a)
                  (apply restfun a))))))

; macros

(mac mapeach (var lst . body)
  " Maps `(fn (,var) ,@body)' over `lst'.
    See also [[each]] [[map]] [[mappendeach]] "
  `(map (fn (,var) ,@body) ,lst))

(mac mappendeach (var lst . body)
  " As 'mapeach, but using 'mappend instead of 'map.
    See also [[mapeach]] [[mappend]] [[each]] "
  `(mappend (fn (,var) ,@body) ,lst))

(mac ado body
  " Anaphoric do.
    See also [[aif]] [[awhen]] [[aand]] "
  (aif cdr.body `(let it ,car.body (ado ,@it))
       car.body))

; now that pg has renamed 'assert to 'set, we're free to use it in its more
; conventional sense
(mac assert (exp (o msg (+ "Assertion failed: "
                           (tostring:ppr exp (len "Assertion failed: ") t))))
  " Errors with `msg' if `exp' evaluates to nil. "
  `(unless ,exp (err ,msg)))

(mac asserts args
  " Asserts each expr in `args', with the default error message. "
  `(do ,@(map [list 'assert _] args)))

(mac switchlet (var expr . cases)
  " Like 'caselet, except it (lazily) evals the expressions compared against.
    See also [[switch]] [[caselet]] [[case]]"
  `(let ,var ,expr
     ,((afn (args)
         (if (no cdr.args) car.args
           `(if (is ,var ,car.args) ,cadr.args
              ,(self cddr.args)))) cases)))

(mac switch (expr . cases)
  " 'switch is to 'switchlet as 'case is to 'caselet.
    See also [[switchlet]] [[case]] [[caselet]]"
  `(switchlet ,(uniq) ,exp ,@cases))

(mac dol (parms (test result) . body)
  " Like the standard lisp/scheme do loop, but with redundant inner parens
    removed."
  (w/uniq loop-name
    (let parms (tuples parms 3)
      `((rfn ,loop-name ,(map1 [_ 0] parms)
          (if ,test ,result
            (do ,@body (,loop-name ,@(map1 [_ 2] parms)))))
         ,@(map1 [_ 1] parms)))))

(mac w/stdoutfile (name . body)
  " Redirects stdout to the file `name' within `body'.
    See also [[w/stdinfile]] [[w/outfile]] [[w/stdout]] "
  (w/uniq str `(w/outfile ,str ,name (w/stdout ,str ,@body))))

(mac w/stdinfile (name . body)
  " Redirects standard input from the file `name' within `body'.
    See also [[w/stdoutfile]] [[w/infile]] [[w/stdin]] "
  (w/uniq str `(w/infile ,str ,name (w/stdin ,str ,@body))))

; binding forms

(mac with/p (vars-vals . body)
  " Scheme/Common Lisp's `let' - ie: 'with with the parens added back.
    Easier to use in macro expansions than 'with.
    See also [[with]] [[withs/p]] "
  `(with ,(apply join vars-vals) ,@body))

(mac withs/p (vars-vals . body)
  " Like Scheme/Common Lisp's `let*' - ie: 'withs with the parens added back.
    Easier to use in macro expansions than 'withs.
    See also [[withs]] [[with/p]] "
  `(withs ,(apply join vars-vals) ,@body))

; a 'with that works for defining recursive fns
(mac withr/p (bindings . body)
  " Scheme's 'letrec.
    See also [[withr]] [[where]] "
  `(let ,(map1 car bindings) nil
     ,@(map [cons 'assign _] bindings)
     ,@body))

(mac withr (bindings . body)
  " Scheme's 'letrec, with the redundant inner parens removed.
    See also [[withf]] [[letf]] [[where]] [[withr/p]] "
  `(withr/p ,pair.bindings ,@body))

; mutually recursive local fns
(mac withf/p (fns . body)
  " Like 'withf, only with extra parens, as in 'with/p compared to 'with.
    See also [[withf]] [[with/p]] [[withr]] [[withr/p]] "
  `(withr/p ,(mapeach (name . rest) fns `(,name (fn ,@rest)))
     ,@body))

(mac withf (fns . body)
  " Defines a set `fns' of mutually recursive local fns within `body'. Each
    three elements of `fn' correspond to a fn name, argument list, and body,
    so you'll need to use 'do if you want a multi-expression fn body.
    Example:

      arc> (withf (is-even (x) (case x 0 t (is-odd (- x 1)))
                   is-odd (x) (case x 0 nil (is-even (- x 1))))
             (keep is-odd (range 0 5)))
      (1 3 5)

    See also [[letf]] [[withr]] "
  `(withf/p ,(tuples fns 3) ,@body))

(mac letf (name args expr . body)
  " Defines a (possibly recursive) local fn `(fn ,args ,expr)' named `name'
    within `body'. Example:

      arc> (letf last (x) (aif cdr.x last.it car.x)
             (last '(x y z)))
      z

    See also [[withf]] [[withr]] "
  `(withf (,name ,args ,expr) ,@body))

; inspired by Haskell
(mac where (expr . parms)
  " Binds `parms' and evaluates `expr'. Examples:

      arc> (where (square x)
              square [* _ _]
              x 2)
      4

    Note that binding is recursive, but that actual assignment of values is done
    in the reverse of the order given, so any variables which are both bound and
    used in `parms' must be used in reverse dependency order:

      arc> (where x x (+ y y) y 0)    ; this works as expected
      y
      arc> (where x y 0 x (+ y y))    ; this doesn't
      nil

    Essentially, this is a reversed form of Scheme's 'letrec,
    with many fewer parentheses. Inspired by Haskell's \"where\".
    See also [[withr]] [[withr/p]] [[withf]] "
  `(withr/p ,(rev:pair parms) ,expr))

; ripoffs - licenses unknown

; once-only by fallintothis
; http://arclanguage.org/item?id=9939
; CHANGED 2009-08-20:
;   + take advantage of 'uniqs, 'with/p, 'zip
;   + wrap 'names in a list if it's an atom
;   + alter indentation slightly
;  - Michael Arntzenius

(mac once-only (names . body)
  (withs (names (check names alist list.names)
          gensyms (uniqs names))
    `(w/uniq ,gensyms
       `(with ,(list ,@(mappend list gensyms names))
          ,(with/p ,(zip names gensyms)
             ,@body)))))

; afnwith by Conan Dalton
; http://arclanguage.org/item?id=10055
; CHANGED 2009-08-15: added docstrings - Michael Arntzenius
(mac rfnwith (name withses . body)
  " Convenient wrapper for applying an rfn using with-like syntax.
    `withses' is a list of argument names and their initial values.
    Best explained by example:

      arc> (rfnwith sum (x (range 1 3))
             (iflet (a . r) x (+ a (sum r)) 0))
      6

    The above example macroexpands to:

      ((rfn sum (x) (iflet (a . r) x (+ a (sum r)) 0))
       (range 1 3))

    See also [[afnwith]] [[w/rfn]] [[rfn]] "
  (let w (pair withses)
    `((rfn ,name ,(map car w) ,@body) ,@(map cadr w))))

(mac afnwith (withses . body)
  " Convenient wrapper for applying an afn using with-like syntax.
    `withses' is a list of argument names and their initial values.
    Best explained by example:

      arc> (afnwith (x (range 1 3))
             (iflet (a . r) x (+ a (self r)) 0))
      6

    See also [[rfnwith]] [[w/afn]] [[afn]] "
  `(rfnwith self ,withses ,@body))

; ripoff: w/afn, by absz
; http://arclanguage.org/item?id=10125
; CHANGED 2009-08-15: added docstrings - Michael Arntzenius

(mac w/rfn (name withses . body)
  " Convenient wrapper for applying an rfn using preexisting variables
    in `withses' as arguments. Best explained by example:

      arc> (let x (range 1 3)
             (w/rfn sum (x)
               (iflet (a . r) x (+ a (sum r)) 0)))
      6

    The above example (w/rfn sum ...) macroexpands to:

      ((rfn sum (x) (iflet (a . r) x (+ a (sum r)) 0))
       x)

    See also [[w/afn]] [[rfnwith]] [[rfn]] "
  `(rfnwith ,name ,(mappend [list _ _] mklist.withses) ,@body))

(mac w/afn (withses . body)
  " Convenient wrapper for applying an afn using the preexisting variables
    in `withses' as arguments. Best explained by example:

      arc> (let x (range 1 3)
             (w/afn (x)
               (iflet (a . r) x (+ a (self r)) 0)))
      6

    The above example (w/afn (x) ...) macroexpands to:

      ((afn (x) (iflet (a . r) x (+ a (sum r)) 0))
       x)

    See also [[w/rfn]] [[afnwith]] [[afn]] "
  `(w/rfn self ,withses ,@body))

; ripoff: between, by Andrew Wilcox
; http://awwx.ws/between
; CHANGED 2010-02-15
;   + bugfix: we were wiping first on every run but the first
;   - Mark Huetsch
; CHANGED 2010-01-02:
;   + added docstrings - Michael Arntzenius
;   + only wipe first on the first run through
;  - Michael Arntzenius

(mac between (var expr within . body)
  " As 'each, but runs `within' between each iteration of `body'.
    See also [[each]] "
  (w/uniq first
    `(let ,first t
       (each ,var ,expr
	 (if ,first
	     (wipe ,first)
	     ,within)
	 ,@body))))

; start Andrew Wilcox (aw) code

; http://awwx.ws/xloop0.arc
(mac xloop (withses . body)
  (let w (pair withses)
      `((rfn next ,(map car w) ,@body) ,@(map cadr w))))

; http://awwx.ws/implicit2.arc
(mac implicit (name (o val))
  `(do (defvar ,name ($.make-parameter ,val))
       (mac ,(sym (string "w/" name)) (v . body)
         (w/uniq (param gv gf)
           `(with (,param (defvar-impl ,',name)
                   ,gv ,v
                   ,gf (fn () ,@body))
              ($ (parameterize ((,param ,gv)) (,gf))))))))

; http://awwx.ws/extend-readtable0.arc
(def extend-readtable (c parser)
  ($
   (current-readtable
    (make-readtable (current-readtable)
                    c
                    'non-terminating-macro
                    (lambda (ch port src line col pos)
                      (parser port))))))

; end aw code

; ripoff: ret, by skenney26
; http://github.com/skenney26/kwizwiz/blob/master/kwizwiz.arc

(mac ret (var val . body)
  `(let ,var ,val ,@body ,var))

; END RIPOFFS

; lib/util.arc: A collection of useful miscellanea

; Contributors:
; - Michael Arntzenius <daekharel@gmail.com>

; Persons we've shamelessly ripped off:
; - Conan Dalton <conan@conandalton.net>
; - absz (http://arclanguage.org/user?id=absz)
; - fallintothis (http://arclanguage.org/user?id=fallintothis)

; License: Do what you want, but it's not my fault!
; This license applies to all code in this file UNLESS OTHERWISE NOTED.

; Feel free to make additions to this file and push them to anarki. Keep it to
; stuff that is widely applicable. Don't remove or change the semantics of stuff
; other people added. Add yourself to the contributors list above if you want.

; If you wish to use a different license, make a comment around the code you've
; contributed noting the license. No licenses that don't permit modification
; (duh) and redistribution (double duh).

; Try and keep track of what is whose in sections with unknown licenses
; ("ripoffs").

; miscellaneous

(def fst (a . _) " Returns its first argument. See also [[snd]] " a)
(def snd (a b . _) " Returns its second argument. See also [[fst]] " b)

(def bool (x)
  " Returns `t' if x is not nil, and `nil' otherwise. "
  (if x t))

(def uniqs (lst)
  " Returns a list of gensyms, one for each element of `lst'. Elements
    of `lst' that are symbols are used as the base names for their
    corresponding gensyms.
    See also [[uniq]] "
  (map1 (iff asym uniq [uniq]) lst))

(def gc () ($.collect-garbage))

; type checkers
(def asym (x) " `t' iff `x' is a symbol. " (isa x 'sym))
(def astring (x) " `t' iff `x' is a string. " (isa x 'string))
(def atable (x) " `t' iff `x' is a table. " (isa x 'table))
(def aint (x) " `t' iff `x' is an int. " (isa x 'int))
(def anum (x) " `t' iff `x' is a num. Note that ints are not nums. "
  (isa x 'num))

; list manipulation

; 'reduce and 'rreduce have somewhat quirky behavior, well-suited to arithmetic
; functions, but otherwise hard to reason about. I usually prefer 'foldl and
; 'foldr.
(def foldl (f v l)
  (if l (foldl f (f v car.l) cdr.l) v))

(def foldr (f v l)
  (foldl flip.f v rev.l))

(def foot (l)
  " Gets the last cons in a proper list. (Fails on dotted lists.) "
  (aif cdr.l foot.it l))

(def join/d ls
  " Destructive join.
    See also [[join]]"
  (foldr (afn (a b) (if b (aif foot.a (do (scdr it b) a) b) a)) nil ls))

(def classify (classifier seq)
  " Groups the elements of `seq' by `classifier', returning back a table,
    whose keys are the results of `classifier' and whose values are lists
    of the corresponding elements of `seq'. For example:

      arc> (classify type '(1 \"foo\" a 2 (b)))
      #hash((cons . ((b))) (int . (2 1)) (string . (\"foo\")) (sym . (a)))

    See also [[partition]] [[keep]] [[rem]] "
  (w/table h
    (each e seq
      (push e (h classifier.e)))))

(def partition (test seq)
  " Equivalent to but more efficient than
   `(list (keep test seq) (rem test seq))'. See also [[keep]] [[rem]] "
  (let (passed failed) nil
    (each e seq
      (if test.e
        (push e passed)
        (push e failed)))
    (list rev.passed rev.failed)))

(def unzip (xs)
  " Precisely as `zip', except that zip's `ls' is unzip's `xs'; so it takes one
    list of lists rather than any number of lists as arguments. Can be thought
    of as performing the inverse operation.
    See also [[zip]] "
  (apply map list xs))

(def zip ls
  " Returns a list of lists; the n-th element of the result is a list of the
    n-th elements of the lists in `ls'. The length of the result is the length
    of the shortest list in `ls'; extra elements in other lists are discarded.
    See also [[unzip]] "
  (unzip ls))

(def mklist (x)
  " Wraps atoms in a list; does nothing if `x' is already a list.
    See also [[atom]] [[alist]] [[list]] "
  (check x alist list.x))

; 'many was precisely the same function as 'acons, hence has been removed (any
; cons has a length > 0, since nil is not a cons). Also, 'popfind has been
; renamed 'pull1, to fit with the newly-added 'rem1.

(def rem1 (test seq)
  " Returns a copy of `seq' with the first element that passes `test' removed.
    See also [[rem]] [[keep]] [[pull1]] [[pull]] "
  (zap testify test)
  (if alist.seq ((afn (s)
                   (if no.s nil
                       (f car.s) cdr.s
                       (cons car.s (self cdr.s))))
                 seq)
      (coerce (rem1 test (coerce seq 'cons)) 'string)))

(mac pull1 (test place)
  " Removes the first element that passes `test' from `place'.
    See also [[pull]] [[rem1]] [[rem]] [[keep]] "
  `(= ,place (rem1 ,test ,place)))

(def butlast (x)
  " Returns a list containing every element of `x' but the last.
    See also: [[cut]] "
  (cut x 0 (- (len x) 1)))

(= len= [is len._a _b])
(= len- [- len._a _b])
(= car< [< car._a car._b])
(= cdar cdr:car)
(= cadar car:cdar)
(= mapcar [map car _])
(= mapcdr [map cdr _])

(def keepkey (key lst) (keep [_ key] lst))
(def mapkey (key lst) (map [_ key] lst))

(def rand-pos (lst) (if lst (rand:len lst)))

(mac pushend (elem lst)
  `(= ,lst (join ,lst (list ,elem))))

(mac popnth (lst n)
  (w/uniq g1
    `(let ,g1 (,lst ,n)
       (= ,lst (+ (cut ,lst 0 ,n) (cut ,lst (+ 1 ,n))))
       ,g1)))

(mac poprand (lst)
  (w/uniq g1
    `(if ,lst
	 (let ,g1 (rand-pos ,lst)
	   (popnth ,lst ,g1)))))

; combinators

(def applied (f)
  " Returns a fn that calls `f' on the list of its arguments.
    For example, 'max is equivalent to `(applied [best > _])'. "
  (fn a (f a)))

(def flip (f)
  " Flips the order of the first two arguments of `f'.
    For example: ((flip cons) 1 2) => (2 . 1) "
  (fn (x y . zs) (apply f y x zs)))

(def curry (f . xs)
  " Partially applies (\"curries\") `f' to `xs'. "
  (fn ys (apply f (join xs ys))))

(def const (x)
  " Creates a fn that takes any number of arguments and returns `x'. "
  (fn _ x))

(def tfn _ " Ignores its arguments and returns t. " t)
(def nilfn _ " Ignores its arguments and returns nil. " nil)

(def norf fns
  " Creates a function which returns `t' iff none of `fns' return `t'
    on its arguments.
    See also [[orf]] [[andf]] [[nor]] "
  (complement (apply orf fns)))

(def iff funs
  " Put simply: iff is to if as andf is to and. Specifically:

    (iff) => idfn
    (iff fun) => fun
    (iff test fun rest ...) => a fn that applies `fun' to its arguments if they
    pass `test', otherwise applies `(iff rest...)' to them.

    Examples:

      arc> ((iff alist car) '(x))
      x
      arc> ((iff alist car) 2)
      2
      arc> ((iff < (fn (x y) x) (fn (x y) y)) 1 2)
      1

    See also [[andf]] [[orf]] [[check]] [[idfn]] "
  (case len.funs
    0 idfn
    1 funs.0
      (withs ((test fun . rest) funs
              restfun (apply iff rest))
        (fn a (if (apply test a) (apply fun a)
                  (apply restfun a))))))

; macros

(mac mapeach (var lst . body)
  " Maps `(fn (,var) ,@body)' over `lst'.
    See also [[each]] [[map]] [[mappendeach]] "
  `(map (fn (,var) ,@body) ,lst))

(mac mappendeach (var lst . body)
  " As 'mapeach, but using 'mappend instead of 'map.
    See also [[mapeach]] [[mappend]] [[each]] "
  `(mappend (fn (,var) ,@body) ,lst))

(mac ado body
  " Anaphoric do.
    See also [[aif]] [[awhen]] [[aand]] "
  (aif cdr.body `(let it ,car.body (ado ,@it))
       car.body))

; now that pg has renamed 'assert to 'set, we're free to use it in its more
; conventional sense
(mac assert (exp (o msg (+ "Assertion failed: "
                           (tostring:ppr exp (len "Assertion failed: ") t))))
  " Errors with `msg' if `exp' evaluates to nil. "
  `(unless ,exp (err ,msg)))

(mac asserts args
  " Asserts each expr in `args', with the default error message. "
  `(do ,@(map [list 'assert _] args)))

(mac switchlet (var expr . cases)
  " Like 'caselet, except it (lazily) evals the expressions compared against.
    See also [[switch]] [[caselet]] [[case]]"
  `(let ,var ,expr
     ,((afn (args)
         (if (no cdr.args) car.args
           `(if (is ,var ,car.args) ,cadr.args
              ,(self cddr.args)))) cases)))

(mac switch (expr . cases)
  " 'switch is to 'switchlet as 'case is to 'caselet.
    See also [[switchlet]] [[case]] [[caselet]]"
  `(switchlet ,(uniq) ,exp ,@cases))

(mac dol (parms (test result) . body)
  " Like the standard lisp/scheme do loop, but with redundant inner parens
    removed."
  (w/uniq loop-name
    (let parms (tuples parms 3)
      `((rfn ,loop-name ,(map1 [_ 0] parms)
          (if ,test ,result
            (do ,@body (,loop-name ,@(map1 [_ 2] parms)))))
         ,@(map1 [_ 1] parms)))))

(mac w/stdoutfile (name . body)
  " Redirects stdout to the file `name' within `body'.
    See also [[w/stdinfile]] [[w/outfile]] [[w/stdout]] "
  (w/uniq str `(w/outfile ,str ,name (w/stdout ,str ,@body))))

(mac w/stdinfile (name . body)
  " Redirects standard input from the file `name' within `body'.
    See also [[w/stdoutfile]] [[w/infile]] [[w/stdin]] "
  (w/uniq str `(w/infile ,str ,name (w/stdin ,str ,@body))))

; binding forms

(mac with/p (vars-vals . body)
  " Scheme/Common Lisp's `let' - ie: 'with with the parens added back.
    Easier to use in macro expansions than 'with.
    See also [[with]] [[withs/p]] "
  `(with ,(apply join vars-vals) ,@body))

(mac withs/p (vars-vals . body)
  " Like Scheme/Common Lisp's `let*' - ie: 'withs with the parens added back.
    Easier to use in macro expansions than 'withs.
    See also [[withs]] [[with/p]] "
  `(withs ,(apply join vars-vals) ,@body))

; a 'with that works for defining recursive fns
(mac withr/p (bindings . body)
  " Scheme's 'letrec.
    See also [[withr]] [[where]] "
  `(let ,(map1 car bindings) nil
     ,@(map [cons 'assign _] bindings)
     ,@body))

(mac withr (bindings . body)
  " Scheme's 'letrec, with the redundant inner parens removed.
    See also [[withf]] [[letf]] [[where]] [[withr/p]] "
  `(withr/p ,pair.bindings ,@body))

; mutually recursive local fns
(mac withf/p (fns . body)
  " Like 'withf, only with extra parens, as in 'with/p compared to 'with.
    See also [[withf]] [[with/p]] [[withr]] [[withr/p]] "
  `(withr/p ,(mapeach (name . rest) fns `(,name (fn ,@rest)))
     ,@body))

(mac withf (fns . body)
  " Defines a set `fns' of mutually recursive local fns within `body'. Each
    three elements of `fn' correspond to a fn name, argument list, and body,
    so you'll need to use 'do if you want a multi-expression fn body.
    Example:

      arc> (withf (is-even (x) (case x 0 t (is-odd (- x 1)))
                   is-odd (x) (case x 0 nil (is-even (- x 1))))
             (keep is-odd (range 0 5)))
      (1 3 5)

    See also [[letf]] [[withr]] "
  `(withf/p ,(tuples fns 3) ,@body))

(mac letf (name args expr . body)
  " Defines a (possibly recursive) local fn `(fn ,args ,expr)' named `name'
    within `body'. Example:

      arc> (letf last (x) (aif cdr.x last.it car.x)
             (last '(x y z)))
      z

    See also [[withf]] [[withr]] "
  `(withf (,name ,args ,expr) ,@body))

; inspired by Haskell
(mac where (expr . parms)
  " Binds `parms' and evaluates `expr'. Examples:

      arc> (where (square x)
              square [* _ _]
              x 2)
      4

    Note that binding is recursive, but that actual assignment of values is done
    in the reverse of the order given, so any variables which are both bound and
    used in `parms' must be used in reverse dependency order:

      arc> (where x x (+ y y) y 0)    ; this works as expected
      y
      arc> (where x y 0 x (+ y y))    ; this doesn't
      nil

    Essentially, this is a reversed form of Scheme's 'letrec,
    with many fewer parentheses. Inspired by Haskell's \"where\".
    See also [[withr]] [[withr/p]] [[withf]] "
  `(withr/p ,(rev:pair parms) ,expr))

; ripoffs - licenses unknown

; once-only by fallintothis
; http://arclanguage.org/item?id=9939
; CHANGED 2009-08-20:
;   + take advantage of 'uniqs, 'with/p, 'zip
;   + wrap 'names in a list if it's an atom
;   + alter indentation slightly
;  - Michael Arntzenius

(mac once-only (names . body)
  (withs (names (check names alist list.names)
          gensyms (uniqs names))
    `(w/uniq ,gensyms
       `(with ,(list ,@(mappend list gensyms names))
          ,(with/p ,(zip names gensyms)
             ,@body)))))

; afnwith by Conan Dalton
; http://arclanguage.org/item?id=10055
; CHANGED 2009-08-15: added docstrings - Michael Arntzenius
(mac rfnwith (name withses . body)
  " Convenient wrapper for applying an rfn using with-like syntax.
    `withses' is a list of argument names and their initial values.
    Best explained by example:

      arc> (rfnwith sum (x (range 1 3))
             (iflet (a . r) x (+ a (sum r)) 0))
      6

    The above example macroexpands to:

      ((rfn sum (x) (iflet (a . r) x (+ a (sum r)) 0))
       (range 1 3))

    See also [[afnwith]] [[w/rfn]] [[rfn]] "
  (let w (pair withses)
    `((rfn ,name ,(map car w) ,@body) ,@(map cadr w))))

(mac afnwith (withses . body)
  " Convenient wrapper for applying an afn using with-like syntax.
    `withses' is a list of argument names and their initial values.
    Best explained by example:

      arc> (afnwith (x (range 1 3))
             (iflet (a . r) x (+ a (self r)) 0))
      6

    See also [[rfnwith]] [[w/afn]] [[afn]] "
  `(rfnwith self ,withses ,@body))

; ripoff: w/afn, by absz
; http://arclanguage.org/item?id=10125
; CHANGED 2009-08-15: added docstrings - Michael Arntzenius

(mac w/rfn (name withses . body)
  " Convenient wrapper for applying an rfn using preexisting variables
    in `withses' as arguments. Best explained by example:

      arc> (let x (range 1 3)
             (w/rfn sum (x)
               (iflet (a . r) x (+ a (sum r)) 0)))
      6

    The above example (w/rfn sum ...) macroexpands to:

      ((rfn sum (x) (iflet (a . r) x (+ a (sum r)) 0))
       x)

    See also [[w/afn]] [[rfnwith]] [[rfn]] "
  `(rfnwith ,name ,(mappend [list _ _] mklist.withses) ,@body))

(mac w/afn (withses . body)
  " Convenient wrapper for applying an afn using the preexisting variables
    in `withses' as arguments. Best explained by example:

      arc> (let x (range 1 3)
             (w/afn (x)
               (iflet (a . r) x (+ a (self r)) 0)))
      6

    The above example (w/afn (x) ...) macroexpands to:

      ((afn (x) (iflet (a . r) x (+ a (sum r)) 0))
       x)

    See also [[w/rfn]] [[afnwith]] [[afn]] "
  `(w/rfn self ,withses ,@body))

; ripoff: between, by Andrew Wilcox
; http://awwx.ws/between
; CHANGED 2010-02-15
;   + update to http://awwx.ws/between0.arc - Mark Huetsch
; CHANGED 2010-01-02:
;   + added docstrings - Michael Arntzenius
;   + only wipe first on the first run through
;  - Michael Arntzenius

(mac between (var expr within . body)
  (w/uniq first
    `(let ,first t
       (each , var ,expr
	 (unless ,first ,within)
	 (wipe ,first)
	 ,@body))))

; start Andrew Wilcox (aw) code

; http://awwx.ws/xloop0.arc
(mac xloop (withses . body)
  (let w (pair withses)
      `((rfn next ,(map car w) ,@body) ,@(map cadr w))))

; http://awwx.ws/implicit2.arc
(mac implicit (name (o val))
  `(do (defvar ,name ($.make-parameter ,val))
       (mac ,(sym (string "w/" name)) (v . body)
         (w/uniq (param gv gf)
           `(with (,param (defvar-impl ,',name)
                   ,gv ,v
                   ,gf (fn () ,@body))
              ($ (parameterize ((,param ,gv)) (,gf))))))))

; http://awwx.ws/extend-readtable0.arc
(def extend-readtable (c parser)
  ($
   (current-readtable
    (make-readtable (current-readtable)
                    c
                    'non-terminating-macro
                    (lambda (ch port src line col pos)
                      (parser port))))))

; end aw code

; ripoff: ret, by skenney26
; http://github.com/skenney26/kwizwiz/blob/master/kwizwiz.arc

(mac ret (var val . body)
  `(let ,var ,val ,@body ,var))

; END RIPOFFS


new extension to walk code

new extension to walk code

; Code analysis. Spun off 21 Dec 07.

; Ought to do more of this in Arc.  One of the biggest advantages
; of Lisp is messing with code.

(def codelines (file)
  (w/infile in file
    (summing test
      (whilet line (readline in)
        (test (aand (find nonwhite line) (isnt it #\;)))))))

(def codeflat (file)
  (len (flat (readall (infile file)))))

(def codetree (file)
  (reduce + 1 (leaves (readall infile.file))))

(def code-density (file)
  (/ (codetree file) (codelines file)))

(def tokcount (files)
  (counts:mappend flat:readall:infile files))

(def common-tokens (files)
  (sort (compare > cadr)
        (rem nonop:car (tablist:tokcount files))))

(def nonop (x)
  (in x 'quote 'unquote 'quasiquote 'unquote-splicing))

(def common-operators (files)
  (keep [and (isa (car _) 'sym) (bound (car _))] (common-tokens files)))

(def top40 (xs)
  (map prn (firstn 40 xs))
  t)

(def space-eaters (files)
  (let counts (tokcount files)
    (let ranking nil
      (maptable (fn (k v)
                  (when (and (isa k 'sym) (bound k))
                    (insort (compare > [* (len (string (car _)))
                                          (cadr _)])
                            (list k v (* (len (string k)) v))
                            ranking)))
                counts)
    ranking)))

;(top40 (space-eaters allfiles*))

(mac flatlen args `(len (flat ',args)))

(def code (x)
  (annotate 'code x))

(defextend walk (seq f) (isa seq 'code)
  (let x rep.seq
    (f x)
    (if (acons x)
      (each elem x
        (walk code.elem f)))))